packages feed

stack 1.9.3.1 → 2.1.1

raw patch · 186 files changed

+15060/−18917 lines, 186 filesdep +arraydep +colourdep +hi-file-parserdep −bindings-unamedep −monad-loggerdep −storedep ~QuickCheckdep ~ansi-terminaldep ~conduitnew-component:exe:stack-integration-test

Dependencies added: array, colour, hi-file-parser, http-download, optparse-generic, pantry-tmp, raw-strings-qq, resource-pool, rio-prettyprint, terminal-size

Dependencies removed: bindings-uname, monad-logger, store, store-core

Dependency ranges changed: QuickCheck, ansi-terminal, conduit, conduit-extra, exceptions, extra, fsnotify, generic-deriving, hpack, hspec, http-client, http-conduit, mono-traversable, optparse-simple, persistent, persistent-sqlite, process, resourcet, retry, rio, streaming-commons, th-reify-many, unliftio, vector, zip-archive

Files

CONTRIBUTING.md view
@@ -135,13 +135,13 @@ Running the integration tests is a little involved, you'll need to:  ```bash-$ stack test stack:stack-integration-test --flag stack:integration-tests+$ stack build --flag stack:integration-tests stack --interleaved-output --exec stack-integration-test ```  Running an individual module works like this:  ```bash-$ stack test stack:stack-integration-test --flag stack:integration-tests --ta "-m <PATTERN>"+$ stack build --flag stack:integration-tests stack --interleaved-output --exec "stack-integration-test -m <PATTERN>" ```  Where `<PATTERN>` is the name of the folder listed in the@@ -160,6 +160,39 @@ [test/integration/tests/](https://github.com/commercialhaskell/stack/tree/master/test/integration/tests) folder. +## CI Build rules++We use [Azure](https://dev.azure.com/commercialhaskell/stack/_build)+to do CI builds on Stack. There are two types of build which happens+there:++### Test suite build++This builds the code with `--pedantic`, performs hlint checks and it+runs all test suites on multiple GHC/OS configuration. These are the+rules for triggering it:++* CI will run this if commits are pushed to stable, master branch+* CI will run this for any branches starting with `ci/`+* CI will run this for all new PR's.++### Integration based build++This build runs the integration tests in the Stack codebase. This is+scheduled to run daily once for both the stable and master branches.++Also, you can manually run this on a specific branch from the Azure UI+if you have the appropriate permissions. If you'd specifically like a+branch or PR to run integration tests, add a comment in the PR and we+can queue one up.+++### Skipping build++There are times (like a minor type fix) where you don't want the CI to+run. For those cases, you can add `[skip ci]` or `[ci skip]` in your+commit message to skip the builds. For more details, [refer+here](https://github.com/Microsoft/azure-pipelines-agent/issues/858#issuecomment-475768046).  ## Slack channel
ChangeLog.md view
@@ -1,6 +1,303 @@ # Changelog  +## v2.1.1++**Changes since v1.9.3**++Major changes:++* Switch over to pantry for managing packages. This is a major change+  to Stack's internals, and affects user-visible behavior in a few+  places. Some highlights:+    * Drop support for multiple package indices and legacy+      `00-index.tar` style indices. See+      [#4137](https://github.com/commercialhaskell/stack/issues/4137).+    * Support for archives and repos in the `packages` section has+      been removed. Instead, you must use `extra-deps` for such+      dependencies. `packages` now only supports local filepaths.+    * Add support for Git repositories containing (recursive) submodules.+    * Addition of new configuration options for specifying a "pantry+      tree" key, which provides more reproducibility around builds,+      and (in the future) will be used for more efficient package+      content downloads. You can also specify package name and version+      for more efficient config parsing.+          * __NOTE__ The new `stack freeze` command provides support+            for automatically generating this additional+            information.+    * Package contents and metadata are stored in an SQLite database+      in place of files on the filesystem. The `pantry` library can be+      used for interacting with these contents.+    * Internally, Stack has changed many datatypes, including moving+      to Cabal's definition of many data types. As a result of such+      changes, existing cache files will in general be invalidated,+      resulting in Stack needing to rebuild many previously cached+      builds in the new version. Sorry :(.+    * A new command, `stack freeze` has been added which outputs+      project and snapshot definitions with dependencies pinned to+      their exact versions.+    * The `ignore-revision-mismatch` setting is no longer needed, and+      has been removed.+    * Overriding GHC boot packages results in any other GHC boot+      packages depending on it being no longer available as a dependency,+      such packages need to be added explicitly when needed. See+      [#4510] (https://github.com/commercialhaskell/stack/issues/4510).+    * Cabal solver integration was not updated to support newer+      `cabal-install` versions so `stack solver` command was removed as+      well as a related option `--solver` from `stack new` and+      `stack init`.+* Upgrade to Cabal 2.4+    * Note that, in this process, the behavior of file globbing has+      been modified to match that of Cabal. In particular, this means+      that for Cabal spec versions less than 2.4, `*.txt` will+      match `foo.txt`, but not `foo.2.txt`.+* Remove the `stack image` command. With the advent of Docker multistage+  builds, this functionality is no longer useful. For an example, please see+  [Building Haskell Apps with+  Docker](https://www.fpcomplete.com/blog/2017/12/building-haskell-apps-with-docker).+* Support building GHC from source (experimental)+    * Stack now supports building and installing GHC from source. The built GHC+      is uniquely identified by a commit id and an Hadrian "flavour" (Hadrian is+      the newer GHC build system), hence `compiler` can be set to use a GHC+      built from source with `ghc-git-COMMIT-FLAVOUR`+* `stack.yaml` now supports a `configure-options`, which are passed directly to+  the `configure` step in the Cabal build process. See+  [#1438](https://github.com/commercialhaskell/stack/issues/1438)+* Remove support for building GHCJS itself. Future releases of Stack+  may remove GHCJS support entirely.+* Support for lock files for pinning exact project dependency versions++Behavior changes:++* `stack.yaml` now supports `snapshot`: a synonym for `resolver`. See+  [#4256](https://github.com/commercialhaskell/stack/issues/4256)+* `stack script` now passes `-i -idir` in to the `ghc`+  invocation. This makes it so that the script can import local+  modules, and fixes an issue where `.hs` files in the current+  directory could affect interpretation of the script. See+  [#4538](https://github.com/commercialhaskell/stack/pull/4538)+* When using `stack script`, custom snapshot files will be resolved+  relative to the directory containing the script.+* Remove the deprecated `--upgrade-cabal` flag to `stack setup`.+* Support the `drop-packages` field in `stack.yaml`+* Remove the GPG signing code during uploads. The GPG signatures have+  never been used yet, and there are no plans to implement signature+  verification.+* Remove the `--plain` option for the `exec` family of commands+* Always use the `--exact-configuration` Cabal configuration option when+  building (should mostly be a non-user-visible enhancement).+* No longer supports Cabal versions older than `1.19.2`.  This means+  projects using snapshots earlier than `lts-3.0` or+  `nightly-2015-05-05` will no longer build.+* Remove the `stack docker cleanup` command.  Docker itself now has+  [`docker image prune`](https://docs.docker.com/engine/reference/commandline/image_prune/)+  and+  [`docker container prune`](https://docs.docker.com/engine/reference/commandline/container_prune/),+  which you can use instead.+* Interleaved output is now turned on by default, see+  [#4702](https://github.com/commercialhaskell/stack/issues/4702). In+  addition, the `packagename> ` prefix is no longer included in+  interelaved mode when only building a single target.+* The `-fhide-source-paths` GHC option is now enabled by default and+  can be disabled via the `hide-source-paths` configuration option in+  `stack.yaml`. See [#3784](https://github.com/commercialhaskell/stack/issues/3784)+* Stack will reconfigure a package if you modify your `PATH` environment+  variable. See+  [#3138](https://github.com/commercialhaskell/stack/issues/3138).+* For GHC 8.4 and later, disable the "shadowed dependencies" workaround. This+  means that Stack will no longer have to force reconfigures as often. See+  [#3554](https://github.com/commercialhaskell/stack/issues/3554).+* When building a package, Stack takes a lock on the dist directory in+  use to avoid multiple runs of Stack from trampling each others'+  files. See+  [#2730](https://github.com/commercialhaskell/stack/issues/2730).+* Stack will check occassionally if there is a new version available and prompt+  the user to upgrade. This will not incur any additional network traffic, as+  it will piggy-back on the existing Hackage index updates. You can set+  `recommend-stack-upgrade: false` to bypass this. See+  [#1681](https://github.com/commercialhaskell/stack/issues/1681).+* `stack list-dependencies` has been removed in favour of `stack ls dependencies`.+* The new default for `--docker-auto-pull` is enabled. See+  [#3332](https://github.com/commercialhaskell/stack/issues/3332).++Other enhancements:++* Support MX Linux in get-stack.sh. Fixes+  [#4769](https://github.com/commercialhaskell/stack/issues/4769).+* Defer loading up of files for local packages. This allows us to get+  plan construction errors much faster, and avoid some unnecessary+  work when only building a subset of packages. This is especially+  useful for the curator use case.+* Existing global option `--color=WHEN` is now also available as a+  non-project-specific yaml configuration parameter `color:`.+* Adopt the standard proposed at http://no-color.org/, that color should not be+  added by default if the `NO_COLOR` environment variable is present.+* New command `stack ls stack-colors` lists the styles and the associated 'ANSI'+  control character sequences that stack uses to color some of its output. See+  `stack ls stack-colors --help` for more information.+* New global option `--stack-colors=STYLES`, also available as a+  non-project-specific yaml configuration parameter, allows a stack user to+  redefine the default styles that stack uses to color some of its output. See+  `stack --help` for more information.+* British English spelling of 'color' (colour) accepted as an alias for+  `--color`, `--stack-colors`, `stack ls stack-colors` at the command line and+  for `color:` and `stack-colors:` in yaml configuration files.+* New build option `--ddump-dir`. (See +  [#4225](https://github.com/commercialhaskell/stack/issues/4225))+* Stack parses and respects the `preferred-versions` information from+  Hackage for choosing latest version of a package in some cases,+  e.g. `stack unpack packagename`.+* The components output in the `The main module to load is ambiguous` message+  now include package names so they can be more easily copy-pasted.+* Git repos are shared across multiple projects. See+  [#3551](https://github.com/commercialhaskell/stack/issues/3551)+* Use en_US.UTF-8 locale by default in pure Nix mode so programs won't+  crash because of Unicode in their output+  [#4095](https://github.com/commercialhaskell/stack/issues/4095)+* Add `--tree` to `ls dependencies` to list dependencies as tree.+  [#4101](https://github.com/commercialhaskell/stack/issues/4101)+* Add `--pedantic` to `ghci` to run with `-Wall` and `-Werror`+  [#4463](https://github.com/commercialhaskell/stack/issues/4463)+* Add `--cabal-files` flag to `stack ide targets` command.+* Add `--stdout` flag to all `stack ide` subcommands.+* Use batches when unregistering packages with `ghc-pkg`.+  (See [#2662](https://github.com/commercialhaskell/stack/issues/2662))+* `get-stack` script now works on Windows CI machines of Appveyor,+  Travis and Azure Pipelines. See+  [#4535](https://github.com/commercialhaskell/stack/issues/4535)/+* Show snapshot being used when `stack ghci` is invoked outside of a project+  directory. See+  [#3651](https://github.com/commercialhaskell/stack/issues/3651)+* The script interpreter now accepts a `--extra-dep` flag for adding+  packages not present in the snapshot. Currently, this only works+  with packages from Hackage, not Git repos or archives.+* When using the script interpreter with `--optimize` or `--compile`,+  Stack will perform an optimization of checking whether a newer+  executable exists, making reruns significantly faster. There's a+  downside to this, however: if you have a multifile script, and+  change one of the dependency modules, Stack will not automatically+  detect and recompile.+* `stack clean` will delete the entire `.stack-work/dist` directory,+  not just the relevant subdirectory for the current GHC version. See+  [#4480](https://github.com/commercialhaskell/stack/issues/4480).+* Add `stack purge` as a shortcut for `stack clean --full`. See+  [#3863](https://github.com/commercialhaskell/stack/issues/3863).+* Both `stack dot` and `stack ls dependencies` accept a+  `--global-hints` flag to bypass the need for an installed GHC. See+  [#4390](https://github.com/commercialhaskell/stack/issues/4390).+* Add the `stack config env` command for getting shell script environment+  variables. See [#620](https://github.com/commercialhaskell/stack/issues/620).+* Less verbose output from `stack setup` on Windows. See+  [#1212](https://github.com/commercialhaskell/stack/issues/1212).+* Add an optional `ignore-expiry` flag to the `hackage-security`+  section of the `~/.stack/config.yaml`. It allows to disable timestamp+  expiration verification just like `cabal --ignore-expiry` does.+  The flag is not enabled by default so that the default functionality+  is not changed.+* Include default values for most command line flags in the `--help`+  output. See+  [#893](https://github.com/commercialhaskell/stack/issues/893).+* Set the `GHC_ENVIRONMENT` environment variable to specify dependency+  packages explicitly when running test. This is done to prevent+  ambiguous module name errors in `doctest` tests.+* `get-stack` script now works on Windows CI machines of Appveyor,+  Travis and Azure Pipelines. See+  [#4535](https://github.com/commercialhaskell/stack/issues/4535)+* Warn when a Docker image does not include a `PATH` environment+  variable. See+  [#2472](https://github.com/commercialhaskell/stack/issues/2742)+* When using `system-ghc: true`, Stack will now find the appropriate GHC+  installation based on the version suffix, allowing you to more easily switch+  between various system-installed GHCs. See+  [#2433](https://github.com/commercialhaskell/stack/issues/2433).+* `stack init` will now support create a `stack.yaml` file without any local+  packages. See [#2465](https://github.com/commercialhaskell/stack/issues/2465)+* Store caches in SQLite database instead of files.+* No longer use "global" Docker image database (`docker.db`).+* User config files are respected for the script command. See+  [#3705](https://github.com/commercialhaskell/stack/issues/3705),+  [#3887](https://github.com/commercialhaskell/stack/issues/3887).+* Set the `GHC_ENVIRONMENT` environment variable to `-` to tell GHC to+  ignore any such files when GHC is new enough (>= 8.4.4), otherwise+  simply unset the variable. This allows Stack to have control of+  package databases when running commands like `stack exec ghci`, even+  in the presence of implicit environment files created by `cabal+  new-build`. See+  [#4706](https://github.com/commercialhaskell/stack/issues/4706).+* Use a database cache table to speed up discovery of installed GHCs+* You can specify multiple `--test-arguments` options. See+  [#2226](https://github.com/commercialhaskell/stack/issues/2226)+* Windows terminal width detection is now done. See+  [#3588](https://github.com/commercialhaskell/stack/issues/3588)+* On Windows, informs users if the 'programs' path contains a space character+  and further warns users if that path does not have an alternative short+  ('8 dot 3') name, referencing the `local-programs-path` configuration option.+  See [#4726](https://github.com/commercialhaskell/stack/issues/4726)+* Add `--docker-mount-mode` option to set the Docker volume mount mode+  for performance tuning on macOS.++Bug fixes:++* Ignore duplicate files for a single module when a Haskell module was+  generated from a preprocessor file. See+  [#4076](https://github.com/commercialhaskell/stack/issues/4076).+* Only track down components in current directory if there are no+  hs-source-dirs found. This eliminates a number of false-positive+  warnings, similar to+  [#4076](https://github.com/commercialhaskell/stack/issues/4076).+* Handle a change in GHC's hi-dump format around `addDependentFile`,+  which now includes a hash. See+  [yesodweb/yesod#1551](https://github.com/yesodweb/yesod/issues/1551)+* Fix `subdirs` for git repos in `extra-deps` to match whole directory names.+  Also fixes for `subdirs: .`. See+  [#4292](https://github.com/commercialhaskell/stack/issues/4292)+* Fix for git packages to update submodules to the correct state. See+  [#4314](https://github.com/commercialhaskell/stack/pull/4314)+* Add `--cabal-files` flag to `stack ide targets` command.+* Don't download ghc when using `stack clean`.+* Support loading in GHCi definitions from symlinked C files. Without this+  patch, Stack will try to find object files in the directory pointed to+  by symlinks, while GCC will produce the object files in the original+  directory. See+  [#4402](https://github.com/commercialhaskell/stack/pull/4402)+* Fix handling of GitHub and URL templates on Windows. See+  [commercialhaskell/stack#4394](https://github.com/commercialhaskell/stack/issues/4394)+* Fix `--file-watch` not responding to file modifications when running+  inside docker on Mac. See+  [#4506](https://github.com/commercialhaskell/stack/issues/4506)+* Using `--ghc-options` with `stack script --compile` now works.+* Ensure the detailed-0.9 type tests work.+  See [#4453](https://github.com/commercialhaskell/stack/issues/4453).+* Extra include and lib dirs are now order-dependent. See+  [#4527](https://github.com/commercialhaskell/stack/issues/4527).+* Apply GHC options when building a `Setup.hs` file. See+  [#4526](https://github.com/commercialhaskell/stack/issues/4526).+* Stack handles ABI changes in FreeBSD 12 by differentiating that version from+  previous.+* Help text for the `templates` subcommand now reflects behaviour in stack 1.9+  — that it downloads and shows a help file, rather than listing available+  templates.+* Fix detection of aarch64 platform (this broke when we upgraded to a newer+  Cabal version).+* Docker: fix detecting and pulling missing images with `--docker-auto-pull`, see+  [#4598](https://github.com/commercialhaskell/stack/issues/4598)+* Hackage credentials are not world-readable. See+  [#2159](https://github.com/commercialhaskell/stack/issues/2159).+* Warnings are dumped from logs even when color is enabled. See+  [#2997](https://github.com/commercialhaskell/stack/issues/2997)+* `stack init` will now work for cabal files with sublibraries. See+  [#4408](https://github.com/commercialhaskell/stack/issues/4408)+* When the Cabal spec version is newer than the global Cabal version, build+  against the snapshot's Cabal library. See+  [#4488](https://github.com/commercialhaskell/stack/issues/4488)+* Docker: fix detection of expected subprocess failures.  This fixes+  downloading a compatible `stack` executable  when the host `stack` is not+  compatible with the Docker image (on Linux), and doesn't show an unnecessary+  extra error when the in-container re-exec'ed `stack` exits with failure.+* The `stack ghci` command's `--ghc-options` flag now parses multiple options.+  See [#3315](https://github.com/commercialhaskell/stack/issues/3315).++ ## v1.9.3.1  Hackage-only release with no user facing changes (added compatibility
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015-2018, Stack contributors+Copyright (c) 2015-2019, Stack contributors All rights reserved.  Redistribution and use in source and binary forms, with or without@@ -8,7 +8,7 @@     * Redistributions in binary form must reproduce the above copyright       notice, this list of conditions and the following disclaimer in the       documentation and/or other materials provided with the distribution.-    * Neither the name of stack nor the+    * Neither the name of Stack nor the       names of its contributors may be used to endorse or promote products       derived from this software without specific prior written permission.
README.md view
@@ -1,7 +1,6 @@ ## The Haskell Tool Stack -[![Build Status](https://travis-ci.org/commercialhaskell/stack.svg?branch=master)](https://travis-ci.org/commercialhaskell/stack)-[![Windows build status](https://ci.appveyor.com/api/projects/status/c1c7uvmw6x1dupcl?svg=true)](https://ci.appveyor.com/project/snoyberg/stack)+[![Build Status](https://dev.azure.com/commercialhaskell/stack/_apis/build/status/commercialhaskell.stack?branchName=master)](https://dev.azure.com/commercialhaskell/stack/_build/latest?definitionId=1?branchName=master) [![Release](https://img.shields.io/github/release/commercialhaskell/stack.svg)](https://github.com/commercialhaskell/stack/releases) [![Join the chat at https://gitter.im/commercialhaskell/stack](https://badges.gitter.im/commercialhaskell/stack.svg)](https://gitter.im/commercialhaskell/stack?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) @@ -13,3 +12,9 @@ ### Subsystem maintainers  * GHCJS - [Matchwood](https://github.com/matchwood)++NOTE: GHCJS support is considered experimental. In Stack 2.0, we are+removing support for building GHCJS itself; links will be added to+this README for information on separate tools. Issues on GHCJS may be+closed as not supported, and the next major Stack release may remove+GHCJS support entirely.
doc/CONTRIBUTING.md view
@@ -135,13 +135,13 @@ Running the integration tests is a little involved, you'll need to:  ```bash-$ stack test stack:stack-integration-test --flag stack:integration-tests+$ stack build --flag stack:integration-tests stack --interleaved-output --exec stack-integration-test ```  Running an individual module works like this:  ```bash-$ stack test stack:stack-integration-test --flag stack:integration-tests --ta "-m <PATTERN>"+$ stack build --flag stack:integration-tests stack --interleaved-output --exec "stack-integration-test -m <PATTERN>" ```  Where `<PATTERN>` is the name of the folder listed in the@@ -160,6 +160,39 @@ [test/integration/tests/](https://github.com/commercialhaskell/stack/tree/master/test/integration/tests) folder. +## CI Build rules++We use [Azure](https://dev.azure.com/commercialhaskell/stack/_build)+to do CI builds on Stack. There are two types of build which happens+there:++### Test suite build++This builds the code with `--pedantic`, performs hlint checks and it+runs all test suites on multiple GHC/OS configuration. These are the+rules for triggering it:++* CI will run this if commits are pushed to stable, master branch+* CI will run this for any branches starting with `ci/`+* CI will run this for all new PR's.++### Integration based build++This build runs the integration tests in the Stack codebase. This is+scheduled to run daily once for both the stable and master branches.++Also, you can manually run this on a specific branch from the Azure UI+if you have the appropriate permissions. If you'd specifically like a+branch or PR to run integration tests, add a comment in the PR and we+can queue one up.+++### Skipping build++There are times (like a minor type fix) where you don't want the CI to+run. For those cases, you can add `[skip ci]` or `[ci skip]` in your+commit message to skip the builds. For more details, [refer+here](https://github.com/Microsoft/azure-pipelines-agent/issues/858#issuecomment-475768046).  ## Slack channel
doc/ChangeLog.md view
@@ -1,6 +1,303 @@ # Changelog  +## v2.1.1++**Changes since v1.9.3**++Major changes:++* Switch over to pantry for managing packages. This is a major change+  to Stack's internals, and affects user-visible behavior in a few+  places. Some highlights:+    * Drop support for multiple package indices and legacy+      `00-index.tar` style indices. See+      [#4137](https://github.com/commercialhaskell/stack/issues/4137).+    * Support for archives and repos in the `packages` section has+      been removed. Instead, you must use `extra-deps` for such+      dependencies. `packages` now only supports local filepaths.+    * Add support for Git repositories containing (recursive) submodules.+    * Addition of new configuration options for specifying a "pantry+      tree" key, which provides more reproducibility around builds,+      and (in the future) will be used for more efficient package+      content downloads. You can also specify package name and version+      for more efficient config parsing.+          * __NOTE__ The new `stack freeze` command provides support+            for automatically generating this additional+            information.+    * Package contents and metadata are stored in an SQLite database+      in place of files on the filesystem. The `pantry` library can be+      used for interacting with these contents.+    * Internally, Stack has changed many datatypes, including moving+      to Cabal's definition of many data types. As a result of such+      changes, existing cache files will in general be invalidated,+      resulting in Stack needing to rebuild many previously cached+      builds in the new version. Sorry :(.+    * A new command, `stack freeze` has been added which outputs+      project and snapshot definitions with dependencies pinned to+      their exact versions.+    * The `ignore-revision-mismatch` setting is no longer needed, and+      has been removed.+    * Overriding GHC boot packages results in any other GHC boot+      packages depending on it being no longer available as a dependency,+      such packages need to be added explicitly when needed. See+      [#4510] (https://github.com/commercialhaskell/stack/issues/4510).+    * Cabal solver integration was not updated to support newer+      `cabal-install` versions so `stack solver` command was removed as+      well as a related option `--solver` from `stack new` and+      `stack init`.+* Upgrade to Cabal 2.4+    * Note that, in this process, the behavior of file globbing has+      been modified to match that of Cabal. In particular, this means+      that for Cabal spec versions less than 2.4, `*.txt` will+      match `foo.txt`, but not `foo.2.txt`.+* Remove the `stack image` command. With the advent of Docker multistage+  builds, this functionality is no longer useful. For an example, please see+  [Building Haskell Apps with+  Docker](https://www.fpcomplete.com/blog/2017/12/building-haskell-apps-with-docker).+* Support building GHC from source (experimental)+    * Stack now supports building and installing GHC from source. The built GHC+      is uniquely identified by a commit id and an Hadrian "flavour" (Hadrian is+      the newer GHC build system), hence `compiler` can be set to use a GHC+      built from source with `ghc-git-COMMIT-FLAVOUR`+* `stack.yaml` now supports a `configure-options`, which are passed directly to+  the `configure` step in the Cabal build process. See+  [#1438](https://github.com/commercialhaskell/stack/issues/1438)+* Remove support for building GHCJS itself. Future releases of Stack+  may remove GHCJS support entirely.+* Support for lock files for pinning exact project dependency versions++Behavior changes:++* `stack.yaml` now supports `snapshot`: a synonym for `resolver`. See+  [#4256](https://github.com/commercialhaskell/stack/issues/4256)+* `stack script` now passes `-i -idir` in to the `ghc`+  invocation. This makes it so that the script can import local+  modules, and fixes an issue where `.hs` files in the current+  directory could affect interpretation of the script. See+  [#4538](https://github.com/commercialhaskell/stack/pull/4538)+* When using `stack script`, custom snapshot files will be resolved+  relative to the directory containing the script.+* Remove the deprecated `--upgrade-cabal` flag to `stack setup`.+* Support the `drop-packages` field in `stack.yaml`+* Remove the GPG signing code during uploads. The GPG signatures have+  never been used yet, and there are no plans to implement signature+  verification.+* Remove the `--plain` option for the `exec` family of commands+* Always use the `--exact-configuration` Cabal configuration option when+  building (should mostly be a non-user-visible enhancement).+* No longer supports Cabal versions older than `1.19.2`.  This means+  projects using snapshots earlier than `lts-3.0` or+  `nightly-2015-05-05` will no longer build.+* Remove the `stack docker cleanup` command.  Docker itself now has+  [`docker image prune`](https://docs.docker.com/engine/reference/commandline/image_prune/)+  and+  [`docker container prune`](https://docs.docker.com/engine/reference/commandline/container_prune/),+  which you can use instead.+* Interleaved output is now turned on by default, see+  [#4702](https://github.com/commercialhaskell/stack/issues/4702). In+  addition, the `packagename> ` prefix is no longer included in+  interelaved mode when only building a single target.+* The `-fhide-source-paths` GHC option is now enabled by default and+  can be disabled via the `hide-source-paths` configuration option in+  `stack.yaml`. See [#3784](https://github.com/commercialhaskell/stack/issues/3784)+* Stack will reconfigure a package if you modify your `PATH` environment+  variable. See+  [#3138](https://github.com/commercialhaskell/stack/issues/3138).+* For GHC 8.4 and later, disable the "shadowed dependencies" workaround. This+  means that Stack will no longer have to force reconfigures as often. See+  [#3554](https://github.com/commercialhaskell/stack/issues/3554).+* When building a package, Stack takes a lock on the dist directory in+  use to avoid multiple runs of Stack from trampling each others'+  files. See+  [#2730](https://github.com/commercialhaskell/stack/issues/2730).+* Stack will check occassionally if there is a new version available and prompt+  the user to upgrade. This will not incur any additional network traffic, as+  it will piggy-back on the existing Hackage index updates. You can set+  `recommend-stack-upgrade: false` to bypass this. See+  [#1681](https://github.com/commercialhaskell/stack/issues/1681).+* `stack list-dependencies` has been removed in favour of `stack ls dependencies`.+* The new default for `--docker-auto-pull` is enabled. See+  [#3332](https://github.com/commercialhaskell/stack/issues/3332).++Other enhancements:++* Support MX Linux in get-stack.sh. Fixes+  [#4769](https://github.com/commercialhaskell/stack/issues/4769).+* Defer loading up of files for local packages. This allows us to get+  plan construction errors much faster, and avoid some unnecessary+  work when only building a subset of packages. This is especially+  useful for the curator use case.+* Existing global option `--color=WHEN` is now also available as a+  non-project-specific yaml configuration parameter `color:`.+* Adopt the standard proposed at http://no-color.org/, that color should not be+  added by default if the `NO_COLOR` environment variable is present.+* New command `stack ls stack-colors` lists the styles and the associated 'ANSI'+  control character sequences that stack uses to color some of its output. See+  `stack ls stack-colors --help` for more information.+* New global option `--stack-colors=STYLES`, also available as a+  non-project-specific yaml configuration parameter, allows a stack user to+  redefine the default styles that stack uses to color some of its output. See+  `stack --help` for more information.+* British English spelling of 'color' (colour) accepted as an alias for+  `--color`, `--stack-colors`, `stack ls stack-colors` at the command line and+  for `color:` and `stack-colors:` in yaml configuration files.+* New build option `--ddump-dir`. (See +  [#4225](https://github.com/commercialhaskell/stack/issues/4225))+* Stack parses and respects the `preferred-versions` information from+  Hackage for choosing latest version of a package in some cases,+  e.g. `stack unpack packagename`.+* The components output in the `The main module to load is ambiguous` message+  now include package names so they can be more easily copy-pasted.+* Git repos are shared across multiple projects. See+  [#3551](https://github.com/commercialhaskell/stack/issues/3551)+* Use en_US.UTF-8 locale by default in pure Nix mode so programs won't+  crash because of Unicode in their output+  [#4095](https://github.com/commercialhaskell/stack/issues/4095)+* Add `--tree` to `ls dependencies` to list dependencies as tree.+  [#4101](https://github.com/commercialhaskell/stack/issues/4101)+* Add `--pedantic` to `ghci` to run with `-Wall` and `-Werror`+  [#4463](https://github.com/commercialhaskell/stack/issues/4463)+* Add `--cabal-files` flag to `stack ide targets` command.+* Add `--stdout` flag to all `stack ide` subcommands.+* Use batches when unregistering packages with `ghc-pkg`.+  (See [#2662](https://github.com/commercialhaskell/stack/issues/2662))+* `get-stack` script now works on Windows CI machines of Appveyor,+  Travis and Azure Pipelines. See+  [#4535](https://github.com/commercialhaskell/stack/issues/4535)/+* Show snapshot being used when `stack ghci` is invoked outside of a project+  directory. See+  [#3651](https://github.com/commercialhaskell/stack/issues/3651)+* The script interpreter now accepts a `--extra-dep` flag for adding+  packages not present in the snapshot. Currently, this only works+  with packages from Hackage, not Git repos or archives.+* When using the script interpreter with `--optimize` or `--compile`,+  Stack will perform an optimization of checking whether a newer+  executable exists, making reruns significantly faster. There's a+  downside to this, however: if you have a multifile script, and+  change one of the dependency modules, Stack will not automatically+  detect and recompile.+* `stack clean` will delete the entire `.stack-work/dist` directory,+  not just the relevant subdirectory for the current GHC version. See+  [#4480](https://github.com/commercialhaskell/stack/issues/4480).+* Add `stack purge` as a shortcut for `stack clean --full`. See+  [#3863](https://github.com/commercialhaskell/stack/issues/3863).+* Both `stack dot` and `stack ls dependencies` accept a+  `--global-hints` flag to bypass the need for an installed GHC. See+  [#4390](https://github.com/commercialhaskell/stack/issues/4390).+* Add the `stack config env` command for getting shell script environment+  variables. See [#620](https://github.com/commercialhaskell/stack/issues/620).+* Less verbose output from `stack setup` on Windows. See+  [#1212](https://github.com/commercialhaskell/stack/issues/1212).+* Add an optional `ignore-expiry` flag to the `hackage-security`+  section of the `~/.stack/config.yaml`. It allows to disable timestamp+  expiration verification just like `cabal --ignore-expiry` does.+  The flag is not enabled by default so that the default functionality+  is not changed.+* Include default values for most command line flags in the `--help`+  output. See+  [#893](https://github.com/commercialhaskell/stack/issues/893).+* Set the `GHC_ENVIRONMENT` environment variable to specify dependency+  packages explicitly when running test. This is done to prevent+  ambiguous module name errors in `doctest` tests.+* `get-stack` script now works on Windows CI machines of Appveyor,+  Travis and Azure Pipelines. See+  [#4535](https://github.com/commercialhaskell/stack/issues/4535)+* Warn when a Docker image does not include a `PATH` environment+  variable. See+  [#2472](https://github.com/commercialhaskell/stack/issues/2742)+* When using `system-ghc: true`, Stack will now find the appropriate GHC+  installation based on the version suffix, allowing you to more easily switch+  between various system-installed GHCs. See+  [#2433](https://github.com/commercialhaskell/stack/issues/2433).+* `stack init` will now support create a `stack.yaml` file without any local+  packages. See [#2465](https://github.com/commercialhaskell/stack/issues/2465)+* Store caches in SQLite database instead of files.+* No longer use "global" Docker image database (`docker.db`).+* User config files are respected for the script command. See+  [#3705](https://github.com/commercialhaskell/stack/issues/3705),+  [#3887](https://github.com/commercialhaskell/stack/issues/3887).+* Set the `GHC_ENVIRONMENT` environment variable to `-` to tell GHC to+  ignore any such files when GHC is new enough (>= 8.4.4), otherwise+  simply unset the variable. This allows Stack to have control of+  package databases when running commands like `stack exec ghci`, even+  in the presence of implicit environment files created by `cabal+  new-build`. See+  [#4706](https://github.com/commercialhaskell/stack/issues/4706).+* Use a database cache table to speed up discovery of installed GHCs+* You can specify multiple `--test-arguments` options. See+  [#2226](https://github.com/commercialhaskell/stack/issues/2226)+* Windows terminal width detection is now done. See+  [#3588](https://github.com/commercialhaskell/stack/issues/3588)+* On Windows, informs users if the 'programs' path contains a space character+  and further warns users if that path does not have an alternative short+  ('8 dot 3') name, referencing the `local-programs-path` configuration option.+  See [#4726](https://github.com/commercialhaskell/stack/issues/4726)+* Add `--docker-mount-mode` option to set the Docker volume mount mode+  for performance tuning on macOS.++Bug fixes:++* Ignore duplicate files for a single module when a Haskell module was+  generated from a preprocessor file. See+  [#4076](https://github.com/commercialhaskell/stack/issues/4076).+* Only track down components in current directory if there are no+  hs-source-dirs found. This eliminates a number of false-positive+  warnings, similar to+  [#4076](https://github.com/commercialhaskell/stack/issues/4076).+* Handle a change in GHC's hi-dump format around `addDependentFile`,+  which now includes a hash. See+  [yesodweb/yesod#1551](https://github.com/yesodweb/yesod/issues/1551)+* Fix `subdirs` for git repos in `extra-deps` to match whole directory names.+  Also fixes for `subdirs: .`. See+  [#4292](https://github.com/commercialhaskell/stack/issues/4292)+* Fix for git packages to update submodules to the correct state. See+  [#4314](https://github.com/commercialhaskell/stack/pull/4314)+* Add `--cabal-files` flag to `stack ide targets` command.+* Don't download ghc when using `stack clean`.+* Support loading in GHCi definitions from symlinked C files. Without this+  patch, Stack will try to find object files in the directory pointed to+  by symlinks, while GCC will produce the object files in the original+  directory. See+  [#4402](https://github.com/commercialhaskell/stack/pull/4402)+* Fix handling of GitHub and URL templates on Windows. See+  [commercialhaskell/stack#4394](https://github.com/commercialhaskell/stack/issues/4394)+* Fix `--file-watch` not responding to file modifications when running+  inside docker on Mac. See+  [#4506](https://github.com/commercialhaskell/stack/issues/4506)+* Using `--ghc-options` with `stack script --compile` now works.+* Ensure the detailed-0.9 type tests work.+  See [#4453](https://github.com/commercialhaskell/stack/issues/4453).+* Extra include and lib dirs are now order-dependent. See+  [#4527](https://github.com/commercialhaskell/stack/issues/4527).+* Apply GHC options when building a `Setup.hs` file. See+  [#4526](https://github.com/commercialhaskell/stack/issues/4526).+* Stack handles ABI changes in FreeBSD 12 by differentiating that version from+  previous.+* Help text for the `templates` subcommand now reflects behaviour in stack 1.9+  — that it downloads and shows a help file, rather than listing available+  templates.+* Fix detection of aarch64 platform (this broke when we upgraded to a newer+  Cabal version).+* Docker: fix detecting and pulling missing images with `--docker-auto-pull`, see+  [#4598](https://github.com/commercialhaskell/stack/issues/4598)+* Hackage credentials are not world-readable. See+  [#2159](https://github.com/commercialhaskell/stack/issues/2159).+* Warnings are dumped from logs even when color is enabled. See+  [#2997](https://github.com/commercialhaskell/stack/issues/2997)+* `stack init` will now work for cabal files with sublibraries. See+  [#4408](https://github.com/commercialhaskell/stack/issues/4408)+* When the Cabal spec version is newer than the global Cabal version, build+  against the snapshot's Cabal library. See+  [#4488](https://github.com/commercialhaskell/stack/issues/4488)+* Docker: fix detection of expected subprocess failures.  This fixes+  downloading a compatible `stack` executable  when the host `stack` is not+  compatible with the Docker image (on Linux), and doesn't show an unnecessary+  extra error when the in-container re-exec'ed `stack` exits with failure.+* The `stack ghci` command's `--ghc-options` flag now parses multiple options.+  See [#3315](https://github.com/commercialhaskell/stack/issues/3315).++ ## v1.9.3.1  Hackage-only release with no user facing changes (added compatibility
doc/GUIDE.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # User guide @@ -8,6 +8,10 @@ will not teach Haskell or involve much code, and it requires no prior experience with the Haskell packaging system or other build tools. +__NOTE__ This document is probably out of date in some places and+deserves a refresh. If you find this document helpful, please drop a+note on [issue #4252](https://github.com/commercialhaskell/stack/issues/4252).+ ## Stack's functions  stack handles the management of your toolchain (including GHC — the Glasgow@@ -37,10 +41,11 @@  Finally, stack is __isolated__: it will not make changes outside of specific stack directories. stack-built files generally go in either the stack root-directory (default `~/.stack`) or `./.stack-work` directories local to each-project. The stack root directory holds packages belonging to snapshots and any-stack-installed versions of GHC. Stack will not tamper with any system version-of GHC or interfere with packages installed by `cabal` or any other build tools.+directory (default `~/.stack` or, on Windows, `%LOCALAPPDATA%\Programs\stack`)+or `./.stack-work` directories local to each project. The stack root directory+holds packages belonging to snapshots and any stack-installed versions of GHC.+Stack will not tamper with any system version of GHC or interfere with packages+installed by `cabal` or any other build tools.  _NOTE_ In this guide, we'll use commands as run on a GNU/Linux system (specifically Ubuntu 14.04, 64-bit) and share output from that. Output on other@@ -276,6 +281,24 @@ placed to not interfere with any other GHC installation, whether system-wide or even different GHC versions installed by stack. +## Cleaning your project++You can clean up build artifacts for your project using the `stack clean` and `stack purge` commands.++### `stack clean`++`stack clean` deletes the local working directories containing compiler output.+By default, that means the contents of directories in `.stack-work/dist`, for all the `.stack-work` directories within a project.++Use `stack clean <specific-package>` to delete the output for the package _specific-package_ only.++### `stack purge`++`stack purge` deletes the local stack working directories, including extra-deps, git dependencies and the compiler output (including logs).+It does not delete any snapshot packages, compilers or programs installed using `stack install`. This essentially+reverts the project to a completely fresh state, as if it had never been built.+`stack purge` is just a shortcut for `stack clean --full`+ ### The build command  The build command is the heart and soul of stack. It is the engine that powers@@ -549,6 +572,8 @@ Assuming it finds a match, it will write your `stack.yaml` file, and everything will work. +(Note: yackage does not currently support hpack, but you can also hpack-convert should you need to generate a package.yaml).+ #### External Dependencies  Given that LTS Haskell and Stackage Nightly have ~1400 of the most common@@ -556,9 +581,9 @@ at times, you may find that not all dependencies required may be available in the Stackage snapshots. -Let's simulate an unsatisfied dependency by adding acme-missiles to the `.cabal` file-(yackage does not currently support hpack, but you can also [hpack-convert](https://github.com/yamadapc/hpack-convert)-should you need to generate a `package.yaml`) build-depends and then re-initing:+Let's simulate an unsatisfied dependency by adding acme-missiles to the list of dependencies+the build requires. This is done by including it in the `Build-depends` section in the .cabal file+and then re-initing:  ``` cueball:~/yackage-0.8.0$ stack init --force@@ -581,7 +606,7 @@ cueball:~/yackage-0.8.0$ stack install cabal-install ``` -Then run the above `stack init` command above again and it will succeed.+Then run the above `stack init` command again and it will succeed.  As you can verify by viewing `stack.yaml`, three external dependencies were added by stack init under the `extra-deps` field. Of course, you could have added the@@ -1196,7 +1221,8 @@ what needs to be removed:  1. The stack executable itself-2. The stack root, e.g. `$HOME/.stack` on non-Windows systems.+2. The stack root, e.g. `$HOME/.stack` on non-Windows systems or, on Windows,+   `%LOCALAPPDATA%\Programs\stack`.     * See `stack path --stack-root`     * On Windows, you will also need to delete `stack path --programs` 3. Any local `.stack-work` directories inside a project@@ -1661,86 +1687,9 @@  ### Docker -stack provides two built-in Docker integrations. The first way is to-build your code inside a Docker image, which means:--* even more reproducibility to your builds, since you and the rest of your team-  will always have the same system libraries-* the Docker images ship with entire precompiled snapshots. That means you have-  a large initial download, but much faster builds--The second way is to generate Docker images for you containing your-built executables (the executable is built in your local machine and-copied into the image) .  This feature is great for automating-deployments from CI. This feature is not yet well-documented, but the-basics are to add a section like the following to stack.yaml:--```yaml-image:--  # You need a `containers` yaml section for `stack image container`.-  # A `container` section that does not contain a list is also valid.-  containers:--    # This example just has one container.-    --      # You need a base image name. Stack layers exes on top of-      # the base image. Prepare your project image in advance by-      # putting all your runtime dependencies in the image.-      base: "fpco/ubuntu-with-libgmp:14.04"--      # You can optionally name the image. Stack will use the project-      # directory name if you leave out this option.-      name: "fpco/hello-world"--      # Optionally add a directory to a path inside the docker image.-      add:-        man/: /usr/local/share/man/--      # Optionally specify a list of executables. Stack will create-      # a tagged image for each in the list. these images will have-      # their respective "ENTRYPOINT" set.-      entrypoints:-        - stack-```--and then run `stack image container` and then `docker images` to list-the images.--Note that the executable will be built in the development environment-and copied to the container, so the dev OS must match that of the-container OS. Note that you can use the `--docker` option to build-your code inside the Docker container in case you have a different-development environment or if you specifically want to build on the-container.--The executable will be stored under `/usr/local/bin/<your-project>-exe`-in the running container.--If you want the container to run the executable immediately on startup-then set an entrypoint as follows:--```yaml-entrypoints:-    - <your-project>-exe-```--The difference between the first and second integration methods is-that in the first one your Haskell code is actually built in the-container whereas in the second one the executable built in your host-machine is copied to the container. The presence of the following-configuration in `stack.yaml` informs stack to switch to the first-integration method:--```yaml-docker:-    enable: true-```--Alternatively, instead of the above configuration, you can use the-`--docker` option to achieve the same.  You can find more details-about the first integration method [in the Docker integration-documentation](./docker_integration.md).+Stack is able to build your code inside a Docker image, which means+even more reproducibility to your builds, since you and the rest of+your team will always have the same system libraries.  ### Nix
doc/README.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # The Haskell Tool Stack @@ -17,7 +17,7 @@  #### How to install -For many Un*x operating systems, all you need to do is run:+For most Un*x operating systems, the easiest way to install is to run:      curl -sSL https://get.haskellstack.org/ | sh @@ -28,10 +28,16 @@ On Windows, you can download and install the [Windows 64-bit Installer](https://get.haskellstack.org/stable/windows-x86_64-installer.exe). -For detailed instructions and downloads, including many additional-operating systems, check out the-[install and upgrade page](install_and_upgrade.md).+For other operating systems and direct downloads, check out the+[install and upgrade guide](install_and_upgrade.md). +Note that the [get.haskellstack.org](https://get.haskellstack.org/)+script will ask for root access using `sudo` in order to use your+platform's package manager to install dependencies and to install to+`/usr/local/bin`.  If you prefer more control, follow the manual+installation instructions in the+[install and upgrade guide](install_and_upgrade.md).+ #### Quick Start Guide  First you need to [install it (see previous section)](#how-to-install).@@ -71,18 +77,21 @@  ``` .-├── LICENSE-├── Setup.hs ├── app │   └── Main.hs+├── ChangeLog.md+├── LICENSE ├── my-project.cabal+├── package.yaml+├── README.md+├── Setup.hs ├── src │   └── Lib.hs ├── stack.yaml └── test     └── Spec.hs -    3 directories, 7 files+    3 directories, 10 files ```  So to manage your library:@@ -142,9 +151,9 @@ λ: :main --stack-root /path/to/root/ --stack-yaml /path/to/stack.yaml COMMAND ``` -This allows you to set a special stack root (instead of `~/.stack/`) and to-target your commands at a particular `stack.yaml` instead of the one found in-the current directory.+This allows you to set a special stack root (instead of `~/.stack/` or, on+Windows, `%LOCALAPPDATA%\Programs\stack`) and to target your commands at a+particular `stack.yaml` instead of the one found in the current directory.  #### Complete guide to stack @@ -197,4 +206,3 @@  #### How to uninstall Removing ``~/.stack`` and ``/usr/local/bin/stack`` should be sufficient. You may want to delete ``.stack-work`` folders in any Haskell projects that you have built.-
doc/SIGNING_KEY.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # Signing key
− doc/architecture.md 
@@ -1,184 +0,0 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>--# Architecture--## 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-* 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.--## Databases--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)--## Building--### Shadowing--Every project must have precisely one version of a package. If one of your-local packages or extra dependencies conflicts with a package in the snapshot,-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--After shadowing, you end up with what is called internally a `SourceMap`, which-is `Map PackageName PackageSource`, where a `PackageSource` can be either a-local package, or a package taken from a package index (specified as a version-number and the build flags).--### Installed packages--Once you have a `SourceMap`, you can inspect your three available databases and-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-* Otherwise: include the package in the list of installed packages--We do something similar for executables, but maintain our own database of-installed executables, since GHC does not track them for us.--### Plan construction--When running a build, we know which packages we want installed (inventively-called "wanteds"), which packages are available to install, and which are-already installed. In plan construction, we put this information together to-decide which packages must be built. The code in Stack.Build.ConstructPlan is-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--### Plan execution--Once we have the plan, execution is a relatively simple process of calling-`runghc Setup.hs` in the correct order with the correct parameters. See-Stack.Build.Execute for more information.--## Configuration--stack has two layers of configuration: project and non-project. All of these-are stored in stack.yaml files, but the former has extra fields (resolver,-packages, extra-deps, and flags). The latter can be monoidally combined so that-a system config file provides defaults, which a user can override with-`~/.stack/config.yaml`, and a project can further customize. In addition,-environment variables STACK\_ROOT and STACK\_YAML can be used to tweak where-stack gets its configuration from.--stack follows a simple algorithm for finding your project configuration file:-start in the current directory, and keep going to the parent until it finds a-`stack.yaml`. When using `stack ghc` or `stack exec` as mentioned above, you'll-sometimes want to override that behavior and point to a specific project in-order to use its databases and bin directories. To do so, simply set the-`STACK_YAML` environment variable to point to the relevant `stack.yaml` file.--## Snapshot auto-detection--When you run `stack build` with no stack.yaml, it will create a basic-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--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-* 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-cannot occur, which should help guide you through the steps necessary for the-second and third option above. Also, note that those options can be-mixed-and-matched, e.g. you may decide to relax some version bounds in your-.cabal file, while also adding some extra-deps.--## Explicit breakage--As mentioned above, updating your package indices will not cause stack to-invalidate any existing package databases. That's because stack is always-explicit about build plans, via:--1. the selected snapshot-2. the extra-deps-3. local packages--The only way to change a plan for packages to be installed is by modifying one-of the above. This means that breakage of a set of installed packages is an-*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.
+ doc/azure_ci.md view
@@ -0,0 +1,206 @@+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>++# Azure CI++This page documents how to use Stack on [Azure+CI](http://dev.azure.com/).++## Quick Start++Note that you have to create [azure+pipelines](#creating-azure-pipelines) for your project and then you+need to put the relevant configuration files:++* For simple Azure configuration, copy-paste the+  [azure-simple](https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/azure/azure-simple.yml)+  file into `azure-pipelines.yml`.+* For complex Azure configuration, you need to take the below linked+  four files and put all of them into the `.azure` directory except+  the `azure-pipelines.yml` file which should be put in the root of+  the repository.++For a more detailed explanation, you can read further.++## Simple and Complex configuration++We provide two fully baked configuration ready to be+used on your projects:++* [The simple Azure configuration](https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/azure/azure-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 Azure configuration 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. In the provided template, we use the Linux+  build configuration to test against various combinations of+  cabal-install and stack. The macOS and Windows configuration is used+  only for testing Stack build configuration. These are the files for+  the complex configuration:+  - [azure-pipelines.yml](https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/azure/azure-pipelines.yml) : This is the starter file used by the Azure CI.+  - [azure-linux-template.yml](https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/azure/azure-linux-template.yml) : Template for Azure Linux build+  - [azure-osx-template.yml](https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/azure/azure-osx-template.yml) : Template for Azure macOS build+  - [azure-windows-template.yml](https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/azure/azure-windows-template.yml) : Template for Azure Windows build++  __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.++## Creating Azure Pipelines++Each of these configurations is ready to be used immediately. But+before we go into where to put them, we have to create pipeline for+your project in Azure CI platform:++* Go to [dev.azure.com](https://dev.azure.com). You have to initially+  sign-in to your microsoft account there.+* Once you have logged in to your Microsoft account, you have to sign+  in to [Azure+  devops](https://user-images.githubusercontent.com/737477/52465678-70963080-2ba5-11e9-83d8-84112b140236.png)+  from there.+* You will be [greeted with a+  dashboard](https://user-images.githubusercontent.com/737477/52465677-70963080-2ba5-11e9-904a-c15c7c0524ef.png)+  where you can create your projects.+* Click the "Create Project" button and fill the [relevant information+  in the dialog](https://user-images.githubusercontent.com/737477/52465676-70963080-2ba5-11e9-82a4-093ee58f11c9.png) and then click the "Create" button.+* This will lead you to the [project+  dashboard](https://user-images.githubusercontent.com/737477/52465675-6ffd9a00-2ba5-11e9-917e-3dec251fcc87.png)+  page where you can create pipelines.+* Click on "Pipelines" in the left menu. This will load the [pipelines+  page](https://user-images.githubusercontent.com/737477/52465673-6ffd9a00-2ba5-11e9-97a4-04e703ae1fbc.png)+  on the right.+* Click on the button "New Pipeline" and you have to follow through+  the wizard there. You need to choose your github repository (or+  Azure repos) and follow the wizard. Note that in the [Configure+  step](https://user-images.githubusercontent.com/737477/52465670-6ffd9a00-2ba5-11e9-83a3-9fffdacbf249.png)+  you have to select the "Starter Pipeline". This will open up an+  [editor+  window](https://user-images.githubusercontent.com/737477/52465669-6f650380-2ba5-11e9-9662-e9c6fc2682b5.png). You+  can leave the existing yaml configuration there as it is and click+  the "Save and run" button.  That will popup a+  [dialog](https://user-images.githubusercontent.com/737477/52465668-6f650380-2ba5-11e9-9203-6347a609e3c4.png). Select+  the relevant option and click "Save and run" button. (Note that this+  step would have created `azure-pipelines.yml` in your repository,+  you have replace that with the appropriate configuration file.)++The rest of this document explains the details of common Azure+configurations for those of you who want to tweak the above+configuration files or write your own.++*Note:* both Azure and Stack infrastructures are actively+ developed. We try to document best practices at the moment.++## Infrastructure++Note that you need at least one agent to build your code. You can+specify which virtual image you want to choose using this configuration:++``` yaml+pool:+  vmImage: ubuntu-16.04+```++The other popular options are `macOS-10.13`, `vs2017-win2016` for Mac+and Windows respectively. You can find the [complete+list](https://docs.microsoft.com/en-us/azure/devops/pipelines/agents/hosted?view=vsts&tabs=yaml)+here.++Note that as of now, Azure CI doesn't offer any caching support. You+can use something like [cache-s3](https://github.com/fpco/cache-s3)+for explicit caching, although it may cost you. For a project with an+example usage of `cache-s3`, you can see the Azure configuration of+[stack](https://github.com/commercialhaskell/stack) repository.++## Installing Stack++Currently there is only one reasonable way to install Stack: fetch precompiled+binary from the Github.++```yaml+- script: |+    mkdir -p ~/.local/bin+    curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'+  displayName: Install Stack+```++## Installing GHC++There are two ways to install GHC:++- Let Stack download GHC+- Install GHC using apt package manger. This method is only applicable+  for Debian based images.++See the [simple azure+script](https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/azure/azure-simple.yml)+for an example of the first option (letting Stack download GHC). Here,+we will show the second option:++```yaml+sudo add-apt-repository -y ppa:hvr/ghc+sudo apt-get update+sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER+```++For the above commands to work, you need to set the `CABALVER` and+`GHCVER` environment variable properly.++### Multiple GHC - parametrised builds++For different GHC versions, you probably want to use different+`stack.yaml` files. If you don't want to put a specific `stack.yaml`+for a particular resolver and still want to test it, you have specify+your resolver argument in `ARGS` environment variable (you will see an+example below). For cabal based builds, you have to specify both+`GHCVER` and `CABALVER` environment variables.++```+strategy:+  matrix:+    stack-def:+      BUILD: stack+      STACK_YAML: stack.yaml+    stack-lts-13:+      BUILD: stack+      STACK_YAML: stack-lts-13.yaml+    cabal-8.4.4:+      BUILD: cabal+      GHCVER: 8.4.4+      CABALVER: 2.4+    cabal-8.6.5:+      BUILD: cabal+      GHCVER: 8.6.5+      CABALVER: 2.4+    nightly:+      BUILD: stack+      ARGS: "--resolver nightly"+    style:+      BUILD: style+    pedantic:+      BUILD: pedantic+      STACK_YAML: stack.yaml+```++## Running tests++After the environment setup, actual test running is simple:++```yaml+script:+  - stack test+```++## Other details++Some Stack commands will run for long time. To avoid timeouts, use the [timeoutInMinutes](https://docs.microsoft.com/en-us/azure/devops/pipelines/process/phases?tabs=yaml&view=azdevops#timeouts) for jobs.++## Examples++- [commercialhaskell/stack](https://github.com/commercialhaskell/stack/blob/master/azure-pipelines.yml)+- [psibi/tldr-hs](http://github.com/psibi/tldr-hs)+- [psibi/wai-slack-middleware](https://github.com/psibi/wai-slack-middleware)
doc/build_command.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # Build command
+ doc/build_overview.md view
@@ -0,0 +1,273 @@+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>++# Build Overview++__NOTE__ This document should *not be considered accurate* until this+note is removed.++This is a work-in-progress document covering the build process used by Stack.+It was started following the Pantry rewrite work in Stack (likely to+land as Stack 2.0), and contains some significant changes/simplifications from+how things used to work. This document will likely not fully be reflected in+the behavior of Stack itself until late in the Stack 2.0 development cycle.++## Terminology++* Project package: anything listed in `packages` in stack.yaml+* Dependency: anything listed in extra-deps or a snapshot+* Target: package and/or component listed on the command line to be built. Can+  be either project package or dependency. If none specified, automatically+  targets all project packages+* Immutable package: a package which comes from Hackage, an archive, or a+  repository. In contrast to...+* Mutable package: a package which comes from a local file path. The contents+  of such a package are assumed to mutate over time.+* Write only database: a package database and set of executables for a given set+  of _immutable_ packages. Only packages from immutable sources and which+  depend exclusively on other immutable packages can be in this database.+  *NOTE* formerly this was the _snapshot database_.+* Mutable database: a package database and set of executables for packages which+  are either mutable or depend on such mutable packages. Importantly, packages+  in this database can be unregister, replaced, etc, depending on what happens+  with the source packages. *NOTE* formerly this was the *local database*.++Outdated terminology to be purged:++* Wanted+* Local+* Snapshot package++## Inputs++Stack pays attention to the following inputs:++* Current working directory, used for finding the default `stack.yaml` file and+  resolving relative paths+* The `STACK_YAML` environment variable+* Command line arguments (CLI args), as will be referenced below++Given these inputs, Stack attempts the following process when performing a build.++## Find the `stack.yaml` file++* Check for a `--stack-yaml` CLI arg, and use that+* Check for a `STACK_YAML` env var+* Look for a `stack.yaml` in this directory or ancestor directories+* Fall back to the default global project++This file is parsed to provide the following config values:++* `resolver` (required field)+* `compiler` (optional field)+* `packages` (optional field, defaults to `["."]`)+* `extra-deps` (optional field, defaults to `[]`)+* `flags` (optional field, defaults to `{}`)+* `ghc-options` (optional field, defaults to `{}`)++`flags` and `ghc-options` break down into both _by name_ (applied to a+specific package) and _general_ (general option `*` for flags is only available in CLI).++## Wanted compiler, dependencies, and project packages++* If the `--resolver` CLI is present, ignore the `resolver` and+  `compiler` config values+* Load up the snapshot indicated by the `resolver` (either config+  value or CLI arg). This will provide:+    * A map from package name to package location, flags, GHC options,+      and if a package should be hidden. All package locations here+      are immutable.+    * A wanted compiler version, e.g. `ghc-8.6.5`+* If the `--compiler` CLI arg is set, or the `compiler` config value+  is set (and `--resolver` CLI arg is not set), ignore the wanted+  compiler from the snapshot and use the specified wanted compiler+* Parse `extra-deps` into a `Map PackageName PackageLocation`,+  containing both mutable and immutable package locations. Parse+  `packages` into a `Map PackageName ProjectPackage`.+* Ensure there are no duplicates between these two sets of packages+* Delete any packages from the snapshot packages that appear in+  `packages` or `extra-deps`+* Perform a left biased union between the immutable `extra-deps`+  values and the snapshot packages. Ignore any settings in the+  snapshot packages that have been replaced.+* Apply the `flags` and `ghc-options` by name to these packages overwriting+  any previous values coming from a snapshot. If any values are specified+  but no matching package is found, it's an error. If a flag is not defined+  in the corresponding package cabal file, it's an error.+* We are now left with the following:+    * A wanted compiler version+    * A map from package name to immutable packages with package config (flags, GHC options, hidden)+    * A map from package name to mutable packages as dependencies with package config+    * A map from package name to mutable packages as project packages with package config++## Get actual compiler++Use the wanted compiler and various other Stack config values (not all+listed here) to find the actual compiler, potentially installing it in+the process.++## Global package sources++With the actual compiler discovered, list out the packages available+in its database and create a map from package name to+version/GhcPkgId. Remove any packages from this map which are present+in one of the other three maps mentioned above.++## Resolve targets++Take the CLI args for targets as raw text values and turn them into+actual targets.++* Do a basic parse of the values into one of the following:+    * Package name+    * Package identifier+    * Package name + component+    * Directory+* An empty target list is equivalent to listing the package names of+  all project packages+* For any directories specified, find all project packages in that+  directory or subdirectories therefore and convert to those package+  names+* For all package identifiers, ensure that either the package name+  does not exist in any of the three parsed maps from the "wanted+  compiler" step above, or that the package is present as an immutable+  dependency from Hackage. If so, create an immutable dependency entry+  with default flags, GHC options, and hidden status, and add this+  package to the set of immutable package dependencies.+* For all package names, ensure the package is in one of the four maps+  we have, and if so add to either the dependency or project package+  target set.+* For all package name + component, ensure that the package is a+  project package, and add that package + component to the set of+  project targets.+* Ensure that no target has been specified multiple times. (*FIXME*+  Mihai states: I think we will need an extra consistency step for+  internal libraries. Sometimes stack needs to use the mangled name+  (`z-package-internallibname-z..`), sometimes the+  `package:internallibname` one. But I think this will become obvious+  when doing the code changes.)++We now have an update four package maps, a new set of dependency+targets, and a new set of project package targets (potentially with+specific components).++## Apply named CLI flags++Named CLI flags are applied to specific packages by updating the+config in one of the four maps. If a flag is specified and no package+is found, it's an error. Note that flag settings are added _on top of_+previous settings in this case, and does not replace them. That is, if+previously we have `singleton (FlagName "foo") True` and now add+`singleton (FlagName "bar") True`, both `foo` and `bar` will now be+true. If any flags are specified but no matching package is found,+it's an error. If a flag is not defined in the corresponding package+cabal file, it's an error.++## Apply CLI GHC options++CLI GHC options are applied as general GHC options according to+`apply-ghc-options` setting.++## Apply general flags from CLI++`--flag *:flagname[:bool]` specified on the CLI are applied to any+project package which uses that flag name.++## Apply general GHC options++General options are divided into the following categories:++* `$locals` is deprecated, it's now a synonym for `$project`+* `$project` applies to all project packages, not to any dependencies+* `$targets` applies to all project packages that are targets, not to any+  dependencies or non-target project packages. This is the default option+  for `apply-ghc-options`+* `$everything` applies to all packages in the source map excluding+  global packages++These options get applied to any corresponding packages in+the source map. If some GHC options already exist for such a package then+they get prepended otherwise they get used as is.++## Determine snapshot hash++Use some deterministic binary serialization and SHA256 thereof to get+a hash of the following information:++* Actual compiler (GHC version, path, *FIXME* probably some other+  unique info from GHC, I've heard that `ghc --info` gives you+  something)+* Global database map+* Immutable dependency map++Motivation: Any package built from the immutable dependency map and+installed in this database will never need to be rebuilt.++*FIXME* Caveat: do we need to take profiling settings into account+here? How about Haddock status?++## Determine actual target components++* Dependencies: "default" components (all libraries and executables)+* Project packages:+    * If specific components named: only those, plus any libraries present+    * If no specific components, include the following:+        * All libraries, always+        * All executables, always+        * All test suites, _if_ `--test` specified on command line+        * All benchmarks, _if_ `--bench` specified on command line++## Construct build plan++* Applied to every target (project package or dependency)+* Apply flags, platform, and actual GHC version to resolve+  dependencies in any package analyzed+* Include all library dependencies for all enabled components+* Include all build tool dependencies for all enabled components+  (using the fun backwards compat logic for `build-tools`)+* Apply the logic recursively to come up with a full build plan+* If a task depends exclusively on immutable packages, mark it as+  immutable. Otherwise, it's mutable. The former go into the snapshot+  database, the latter into the local database.++We now have a set of tasks of packages/components to build, with full+config information for each package, and dependencies that must be+built first.++*FIXME* There's some logic to deal with cyclic dependencies between+test suites and benchmarks, where a task can be broken up into+individual components versus be kept as a single task. Need to+document this better. Currently it's the "all in one" logic.++## Unregister local modified packages++* For all mutable packages in the set of tasks, see if any files have+  changed since last successful build and, if so, unregister + delete+  their executables+* For anything which depends on them directly or transitively,+  unregister + delete their executables++## Perform the tasks++* Topological sort, find things which have no dependencies remaining+* Check if already installed in the relevant database+    * Check package database+    * Check Stack specific "is installed" flags, necessary for+      non-library packages+    * For project packages, need to also check which components were+      built, if tests were run, if we need to rerun tests, etc+* If all good: do nothing+* Otherwise, for immutable tasks: check the precompiled cache for an+  identical package installation (same GHC, dependencies, etc). If+  present: copy that over, and we're done.+* Otherwise, perform the build, register, write to the Stack specific+  "is installed" stuff, and (for immutable tasks) register to the+  precompiled cache++"Perform the build" consists of:++* Do a cabal configure, if needed+* Build the desired components+* For all test suites built, unless "no rerun tests" logic is on and+  we already ran the test, _or_ "no run tests" is on, run the test+* For all benchmarks built, unless "no run benchmarks" is on, run the+  benchmark
doc/coverage.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # Code Coverage
doc/custom_snapshot.md view
@@ -1,133 +1,5 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # Custom Snapshots -Custom snapshots were totally reworked with the extensible snapshots-overhaul in Stack 1.6.0, see-[the writeup](https://www.fpcomplete.com/blog/2017/07/stacks-new-extensible-snapshots)-and-[PR #3249](https://github.com/commercialhaskell/stack/pull/3249)). This-documentation covers the new syntax only.--Custom snapshots allow you to create your own snapshots, which provide-a list of packages to use, along with flags, ghc-options, and a few-other settings. Custom snapshots may extend any other snapshot that-can be specified in a `resolver` field. The packages specified follow-the syntax of `extra-deps` in the `stack.yaml` file, with one-exception: to ensure reproducibility of snapshots, local directories-are not allowed for custom snapshots (as they are expected to change-regularly).--```yaml-resolver: lts-8.21 # Inherits GHC version and package set-compiler: ghc-8.0.1 # Overwrites GHC version in the resolver, optional--name: my-snapshot # User-friendly name--# Additional packages, follows extra-deps syntax-packages:-- unordered-containers-0.2.7.1-- hashable-1.2.4.0-- text-1.2.2.1--# Override flags, can also override flags in the parent snapshot-flags:-  unordered-containers:-    debug: true--# Packages from the parent snapshot to ignore-drop-packages:-- wai-extra--# Packages which should be hidden (affects script command's import-# parser-hidden:-  wai: true-  warp: false--# Set GHC options for specific packages-ghc-options:-  warp:-  - -O2-```--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: 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.--### 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-flags:-  text:-    developer: true-```+This content has been moved to the [docs on pantry](pantry.md).
doc/dependency_visualization.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # Dependency visualization
+ doc/developing_on_windows.md view
@@ -0,0 +1,63 @@+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>++# Developing on windows #++On Windows, Stack comes with an installation of+[msys2](https://www.msys2.org/). Msys2 will be used by Stack to+provide a unix-like shell for Stack. This may be necessary for installing some Haskell packages, such as those which use `configure` scripts.+No+matter which terminal you choose (cmd.exe, powershell, git bash or any+other) you can use this environment too by executing all programs+through `stack exec -- program`. This is especially useful if your+project needs some additional tools during the build phase.++Executables and libraries can be installed with Pacman. All tools can+be found [in the package+list](https://github.com/msys2/msys2/wiki/Packages). A [list of+commands](https://github.com/msys2/msys2/wiki/Using-packages) that+work with Pacman is also available. Just remember that+pacman&mdash;like all other tools&mdash;should be started with `stack+exec -- pacman`.++## Setup.hs ##++`Setup.hs` is automatically run inside the stack environment. So when+you need to launch another tool you don't need to prefix the command+with `stack exec --` within the custom `Setup.hs` file.++## Pacman packages to install for common Haskell packages ##++The following lists Pacman packages known to allow the installation of+some common Haskell packages on Windows. Feel free to submit+additional entries via a pull request.++* For [text-icu](https://github.com/bos/text-icu) install `mingw64/mingw-w64-x86_64-icu`++## Cmake ##++Cmake has trouble finding other tools even if they are available on+the `PATH`. Likely this is not a cmake problem but one of the+environment not fully integrating. For example GHC comes with a copy+of GCC which is not installed by msys itself. If you want to use this+GCC you can provide a full path to it, or find it first with+`System.Directory.findExecutable` if you want to launch GCC from a+Haskell file such as `Setup.hs`.++Experience tells that the `mingw-w64` versions of make and cmake are+most likely to work. Though there are other versions available through+pacman, so have a look to see what works for you. Both tools can be+installed with the commands:++```+stack exec -- pacman -R mingw-w64-x86_64-make+stack exec -- pacman -R mingw-w64-x86_64-cmake+```++Even though make and cmake are then both installed into the same+environment. Cmake still seems to have trouble to find make. To help+cmake find GCC and make supply the following flags:++```+-DCMAKE_C_COMPILER=path+-DCMAKE_MAKE_PROGRAM=path+```
doc/docker_integration.md view
@@ -1,13 +1,9 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  Docker integration =============================================================================== -**Note:** This page is mainly about building Haskell packages inside docker containers.-If you want to deploy your built Haskell programs into a docker container,-look [here](GUIDE.md#docker) instead.--`stack` has support for automatically performing builds inside a Docker+Stack has support for automatically performing builds inside a Docker container, using volume mounts and user ID switching to make it mostly seamless. FP Complete provides images for use with stack that include GHC, tools, and optionally have all of the Stackage LTS packages pre-installed in the global@@ -22,6 +18,10 @@ blog post for more information about the motivation and implementation of stack's Docker support. +If you'd like to build Docker images that contain your Haskell+executables, see [Building Haskell Apps with+Docker](https://www.fpcomplete.com/blog/2017/12/building-haskell-apps-with-docker).+ Prerequisites ------------------------------------------------------------------------------- @@ -43,6 +43,10 @@ See [#194](https://github.com/commercialhaskell/stack/issues/194) for details and workarounds. +Note: you may want to use set the `mount-mode` option to `delegated`, since+this can dramatically improve performance on macOS (see+[configuration](#configuration) for more information).+ **Windows does not work at all** (see [#2421](https://github.com/commercialhaskell/stack/issues/2421)). @@ -119,27 +123,6 @@ `stack docker pull` pulls an image from the Docker registry for the first time, or updates the image by pulling the latest version. -### cleanup - Clean up old images and containers--Docker images can take up quite a lot of disk space, and it's easy for them to-build up if you switch between projects or your projects update their images.-This sub-command will help to remove old images and containers.--By default, `stack docker cleanup` will bring up an editor showing the images-and containers on your system, with any stack images that haven't been used-in the last seven days marked for removal.  You can add or remove the `R` in-the left-most column to flag or unflag an image/container for removal.  When-you save the file and quit the text editor, those images marked for removal-will be deleted from your system.  If you wish to abort the cleanup, delete-all the lines from your editor.--If you use Docker for purposes other than stack, you may have other images on-your system as well.  These will also appear in a separate section, but they-will not be marked for removal by default.--Run `stack docker cleanup --help` to see additional options to customize its-behaviour.- ### reset - Reset the Docker "sandbox"  In order to preserve the contents of the in-container home directory between@@ -199,7 +182,7 @@       # If true, the image will be pulled from the registry automatically, without       # needing to run `stack docker pull`.  See the "security" section of this       # document for implications of enabling this.-      auto-pull: false+      auto-pull: true        # If true, the container will be run "detached" (in the background).  Refer       # to the Docker users guide for information about how to manage containers.@@ -229,6 +212,14 @@         - "/foo/bar"         - "/baz:/tmp/quux" +      # Sets the volume mount mode, passed directly to `docker`.+      # The default mode (consistent) is safest, but may suffer poor performance+      # on non-Linux platforms such as macOS, where the `delegated` mode will+      # be significantly faster.+      # See https://docs.docker.com/docker-for-mac/osxfs-caching/+      # for valid values and the implications of changing the default.+      mount-mode: delegated+       # Environment variables to set in the container.  Environment variables       # are not automatically inherited from the host, so if you need any specific       # variables, use the `--docker-env` command-line argument version of this to@@ -237,12 +228,6 @@         - "FOO=BAR"         - "BAR=BAZ QUUX" -      # Location of database used to track image usage, which `stack docker cleanup`-      # uses to determine which images should be kept.  On shared systems, it may-      # be useful to override this in the global configuration file so that-      # all users share a single database.-      database-path: "~/.stack/docker.db"-       # Location of a Docker container-compatible 'stack' executable with the       # matching version. This executable must be built on linux-x86_64 and       # statically linked.@@ -347,7 +332,7 @@ If you do want to do all your work, including editing, in the container, it might be better to use a persistent container in which you can install Ubuntu packages. You could get that by running something like-`stack --docker-container-name=NAME --docker-persist exec --plain bash`. This+`stack --docker-container-name=NAME --docker-persist exec bash`. This means when the container exits, it won't be deleted. You can then restart it using `docker start -a -i NAME`. It's also possible to detach from a container while it continues running in the background using by pressing Ctrl-P Ctrl-Q,
doc/faq.md view
@@ -1,9 +1,9 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # 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+below, see the [Build overview](build_overview.md) page. The goal of the answers here is to be as helpful and concise as possible.  ## What version of GHC is used when I run something like `stack ghci`?@@ -44,7 +44,9 @@  ## What is the relationship between stack and cabal? -* Cabal-the-library is used by stack to build your Haskell code.+* Cabal-the-library is used by stack to build your Haskell code. See the+  [Architecture: Plan Execution](architecture.md#plan-execution) section for+  more detail, including how the Cabal version is chosen. * 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@@ -57,6 +59,9 @@   there may be more options here for new projects in the future (see issue   [253](https://github.com/commercialhaskell/stack/issues/253)) +For detail on the differences between a `stack.yaml` and Cabal package file, see+[stack.yaml vs cabal package file](stack_yaml_vs_cabal_package_file.md).+ ## 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?  You can make tweaks to a snapshot by modifying the `extra-deps` configuration value in your `stack.yaml` file, e.g.:@@ -314,6 +319,10 @@  See the [Travis CI instructions](travis_ci.md) +## How do I use this with Azure CI?++See the [Azure CI instructions](azure_ci.md)+ ## What is licensing restrictions on Windows?  Currently on Windows GHC produces binaries linked statically with [GNU Multiple@@ -351,6 +360,17 @@  Cf. issue [#425](https://github.com/commercialhaskell/stack/issues/425). +Another issue that may arise with building on Windows is as follows. The default+location of stack's programs folder is `%LOCALAPPDATA\Programs\stack`. If there+is a space character in the `%LOCALAPPDATA%` path this may, in some+circumstances, cause problems with building packages that make use of the GNU+project's `autoconf` package and `configure` shell script files. It may be+necessary to override the default location of stack's programs folder. See+[Non-project-specific config option, local-programs-path](yaml_configuration.md)+for more informaton.++Cf. issue [#4726](https://github.com/commercialhaskell/stack/issues/4726)+ ## Can I change stack's default temporary directory?  Stack downloads and extracts files to `$STACK_ROOT/programs` on most platforms,@@ -407,7 +427,7 @@  ## I get strange `ld` errors about recompiling with "-fPIC" -(Updated in December 2017)+(Updated in January 2019)  This is related to more recent versions of Linux distributions that have GCC with PIE enabled by default.  The continuously-updated distros like Arch, in@@ -430,6 +450,12 @@ If you are experiencing this with GHC >= 8.0.2, try running `stack setup --reinstall` if you've upgraded your Linux distribution or you set up GHC before late December 2017.++If GHC doesn't recognize your C compiler as being able to use `-no-pie`,+this can happen even with GCC and Clang, it might be necessary to enable+this feature manually. To do this, just change+`("C compiler supports -no-pie", "NO"),` to `("C compiler supports -no-pie", "YES"),`+in the file `~/.stack/programs/x86_64-osx/ghc-VER/lib/ghc-VER/settings`.  If you are still having trouble after trying the above, check the following for more possible workarounds:
doc/ghci.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # GHCi
doc/ghcjs.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # GHCJS (experimental)
doc/install_and_upgrade.md view
@@ -1,8 +1,8 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # Install/upgrade -For common Un*x operating systems (including macOS), all you need to do is run:+For common Un\*x operating systems (including macOS), all you need to do is run:      curl -sSL https://get.haskellstack.org/ | sh @@ -10,9 +10,12 @@      wget -qO- https://get.haskellstack.org/ | sh -Distribution packages are available for [Ubuntu](#ubuntu), [Debian](#debian),-[Fedora](#fedora),-[Arch Linux](#arch-linux) and [FreeBSD](#freebsd).++Note that this script will ask for root access using `sudo` in order+to use your platform's package manager to install dependencies and to+install to `/usr/local/bin`.  If you prefer more control, follow the+manual installation instructions for your platform below.+ Binaries for other operating systems are listed below, and available on [the GitHub release page](https://github.com/fpco/stack/releases). For the future, we are open to supporting more OSes (to request one, please@@ -21,7 +24,7 @@ Binary packages are signed with this [signing key](SIGNING_KEY.md).  If you are writing a script that needs to download the latest binary, you can-use URLs like `https://get.haskellstack.org/stable/<PLATFORM>.<EXTENSION>` (e.g. //get.haskellstack.org/stable/linux-x86_64.tar.gz) that always point to the latest stable release.+use URLs like `https://get.haskellstack.org/stable/<PLATFORM>.<EXTENSION>` (e.g. https://get.haskellstack.org/stable/linux-x86_64.tar.gz) that always point to the latest stable release.  ## Windows @@ -71,7 +74,7 @@  If you have the popular [brew](https://brew.sh/) tool installed, you can just do: -    brew install stack+    brew install haskell-stack  * The Homebrew formula and bottles are **unofficial** and lag slightly behind new Stack releases, but tend to be updated within a day or two.@@ -86,6 +89,11 @@      xcode-select --install +Starting with macOs 10.14 (Mojave) running `xcode-select --install` [might not be enough](https://forums.developer.apple.com/thread/104296). You will need to install additional headers by running:++    cd /Library/Developer/CommandLineTools/Packages/+    open macOS_SDK_headers_for_macOS_10.14.pkg+ If you are on OS X 10.11 ("El Capitan") and encounter either of these problems, see the linked FAQ entries: @@ -249,7 +257,7 @@ * Extract the archive and place `stack` somewhere on your `$PATH` (see [Path section below](#path))  * Ensure you have required system dependencies installed.  These include GCC, GNU make, xz, perl, libgmp, libffi, and zlib.  We also recommend Git and GPG.  To install these using your package manager:-    * Debian / Ubuntu: `sudo apt-get install g++ gcc libc6-dev libffi-dev libgmp-dev make xz-utils zlib1g-dev git gnupg`+    * Debian / Ubuntu: `sudo apt-get install g++ gcc libc6-dev libffi-dev libgmp-dev make xz-utils zlib1g-dev git gnupg netbase`     * Fedora / CentOS: `sudo dnf install perl make automake gcc gmp-devel libffi zlib xz tar git gnupg` (use `yum` instead of `dnf` on CentOS and Fedora <= 21)         * Fedora 24: In order to use `stack setup` on a 32-bit system, you may           need to run `sudo dnf install ncurses-compat-libs`. If this package is@@ -292,9 +300,9 @@  ## Path -You can install stack by copying it anywhere on your PATH environment variable. We recommend installing in the same directory where stack itself will install executables (that way stack is able to upgrade itself!). On Windows, that directory is `%APPDATA%\local\bin`, e.g. "c:\Users\Michael\AppData\Roaming\local\bin". For other systems, use `$HOME/.local/bin`.+You can install stack by copying it anywhere on your PATH environment variable. A good place to install is the same directory where stack itself will install executables. On Windows, that directory is `%APPDATA%\local\bin`, e.g. `c:\Users\Michael\AppData\Roaming\local\bin`. For other systems, it's `$HOME/.local/bin`. -If you don't have that directory in your PATH, you may need to update your PATH (such as by editing .bashrc).+If you don't have that directory in your PATH, you may need to update your PATH (such as by editing `~/.bashrc`).  If you're curious about the choice of these paths, see [issue #153](https://github.com/commercialhaskell/stack/issues/153)
+ doc/lock_files.md view
@@ -0,0 +1,185 @@+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>++# Lock Files++Stack attempts to provide reproducible build plans. This involves+reproducibly getting the exact same contents of source packages and+configuration options (like cabal flags and GHC options) for a given+set of input files. There are a few problems with making this work:++* Entering all of the information to fully provide reproducibility is+  tedious. This would include things like Hackage revisions, hashes of+  remote tarballs, etc. Users don't want to enter this information.+* Many operations in Stack rely upon a "snapshot hash," which+  transitively includes the completed information for all of these+  dependencies. If any of that information is missing when parsing the+  `stack.yaml` file or snapshot files, it could be expensive for Stack+  to calculate it.++To address this, we follow the (fairly standard) approach of having a+_lock file_. The goal of the lock file is to cache completed+locations of project, snapshot packages and snapshots themselves so that:++* These files can be stored in source control+* Users on other machines can reuse these lock files and get identical+  build plans given that the used local packages and local snapshots are+  the same on those machines+* Rerunning `stack build` in the future is deterministic in the build+  plan, not depending on mutable state in the world like Hackage+  revisions+    * **NOTE** If, for example, a tarball available remotely is+      deleted or the hash changes, it will not be possible for Stack+      to perform the build. However, by deterministic, we mean it+      either performs the same build or fails, never accidentally+      doing something different.++This document explains the contents of a lock file, how they are used,+and how they are created and updated.++## stack.yaml and snapshot files++Relevant to this discussion, the `stack.yaml` file specifies:++* Resolver (the parent snapshot)+* `extra-deps`++The resolver can either specify a compiler version or another snapshot+file. This snapshot file can contain the same information referenced+above for a `stack.yaml`, with the following differences:++* The `extra-deps` are called `packages`+* Drop packages can be included++Some information in these files can be incomplete. Consider:++```yaml+resolver: lts-13.9+packages: []+extra-deps:+- https://hackage.haskell.org/package/acme-missiles-0.3.tar.gz+```++This information is _incomplete_, since the contents of that URL may+change in the future. Instead, you could specify enough information in+the `stack.yaml` file to fully resolve that package. That looks like:++```yaml+extra-deps:+- size: 1442+  url: https://hackage.haskell.org/package/acme-missiles-0.3.tar.gz+  cabal-file:+    size: 613+    sha256: 2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1+  name: acme-missiles+  version: '0.3'+  sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b+  pantry-tree:+    size: 226+    sha256: 614bc0cca76937507ea0a5ccc17a504c997ce458d7f2f9e43b15a10c8eaeb033+```++Users don't particularly feel like writing all of that. Therefore,+it's common to see _incomplete_ information in a `stack.yaml` file.++Additionally, the `lts-13.9` information is _also_ incomplete. While+we assume in general that LTS snapshots never change, there's nothing+that technically prohibits that from happening. Instead, the complete+version of that field is:++```yaml+resolver:+  size: 496662+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/9.yaml+  sha256: 83de9017d911cf7795f19353dba4d04bd24cd40622b7567ff61fc3f7223aa3ea+```++Also something people don't feel like writing by hand.++## Recursive snapshot layers++Snapshot files can be _recursive_, where `stack.yaml` refers to+`foo.yaml`, which refers to `bar.yaml`, which refers to `baz.yaml`. A+local snapshot file can refer to a remote snapshot file (available via+an HTTP(S) URL).++We need to encode information from _all_ of these snapshot layers and+the `stack.yaml` file in the lock file, to ensure that we can detect+if anything changes.++## Performance++In addition to acting as a pure correctness mechanism, the design of a+lock file given here also works as a performance improvement. Instead+of requiring that all snapshot files be fully parsed on each Stack+invocation, we can store information in the lock file and bypass+parsing of the additional files in the common case of no changes.++## Lock file contents++The lock file contains the following information:++* Completed package locations for both `extra-deps` and packages in+  snapshot files+    * **NOTE** This only applies to _immutable_ packages. Mutable+      packages are not included in the lock file.+* Completed information for the snapshot locations++It looks like the following:++```yaml+# Lock file, some message about the file being auto-generated+snapshots:+  # Starts with the snapshot specified in stack.yaml,+  # then continues with the snapshot specified in each+  # subsequent snapshot file+  - original:+      foo.yaml # raw content specified in a snapshot file+    completed:+      file: foo.yaml+      sha256: XXXX+      size: XXXX+  - original:+      lts-13.9+    completed:+      size: 496662+      url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/9.yaml+      sha256: 83de9017d911cf7795f19353dba4d04bd24cd40622b7567ff61fc3f7223aa3ea++packages:+- original: https://hackage.haskell.org/package/acme-missiles-0.3.tar.gz+  completed:+    size: 1442+    url: https://hackage.haskell.org/package/acme-missiles-0.3.tar.gz+    cabal-file:+      size: 613+      sha256: 2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1+    name: acme-missiles+    version: '0.3'+    sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b+    pantry-tree:+      size: 226+      sha256: 614bc0cca76937507ea0a5ccc17a504c997ce458d7f2f9e43b15a10c8eaeb033+```++## Creation++Whenever a `stack.yaml` file is loaded, Stack checks for a lock file+in the same file path, with a `.lock` extension added. For example, if+you run `stack build --stack-yaml stack-11.yaml`, it will use a lock+file in the location `stack-11.yaml.lock`. For the rest of this+document, we'll assume that the files are simply `stack.yaml` and+`stack.yaml.lock`.++If the lock file does not exist, it will be created by:++* Loading the `stack.yaml`+* Loading all snapshot files+* Completing all missing information+* Writing out the new `stack.yaml.lock` file++## Update procedure++When loading a Stack project all completed package or snapshot locations+(even when they were completed using information from a lock file) get+collected to form a new lock file in memory and compare against the one+on disk, writing if there are any differences.
doc/nix_integration.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # Nix integration
doc/nonstandard_project_init.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # Non-standard project initialization @@ -79,17 +79,11 @@   - https://github.com/commercialhaskell/stack/issues/464  ## Using git Repositories-stack has support for packages that reside in remote git locations. -Example:--```-packages:-- '.'-- location:-    git: https://github.com/kolmodin/binary-    commit: 8debedd3fcb6525ac0d7de2dd49217dce2abc0d9-```+Stack has support for packages that reside in remote git locations. Please see+the [YAML configuration+documentation](yaml_configuration.md#git-and-mercurial-repos) for more+information.  ### Issues Referenced   - https://github.com/commercialhaskell/stack/issues/254@@ -115,14 +109,15 @@   - https://github.com/commercialhaskell/stack/issues/565  ## Custom Snapshots-Currently WIP?+See [Custom Snapshots](custom_snapshot.md).+ ### Issues Referenced   - https://github.com/commercialhaskell/stack/issues/111   - https://github.com/commercialhaskell/stack/issues/253   - https://github.com/commercialhaskell/stack/issues/137  ## Intra-package Targets-stack supports intra-package targets, similar to `cabal build COMPONENTS` for+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/pantry.md view
@@ -0,0 +1,474 @@+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>++# Pantry in Stack++Beginning with Stack 1.11, Stack uses the Pantry library for its+specification of snapshots and package locations. Under the surface,+Pantry is geared towards reproducible build plans with+cryptographically secure specification of packages and snapshots.++There are three user-visible components to Pantry's configuration which affect usage of Stack:++* Snapshot location specification (in the `resolver` field)+* Package location specification (in the `extra-deps` field and inside snapshots)+* Snapshot specification, for creating custom snapshots++## Freeze command++As you'll see throughout this document, there is a lot of additional+information that can be provided to Stack to make the configuration+more reproducible and faster to parse. However, it's tedious to+specify these values manually. Therefore, the recommended workflow is:++* Manually write the simple version of a configuration value+* Use `stack freeze` to obtain the more reproducible version++The standard `stack freeze` will operate on your `stack.yaml` file, and provide+you with updated `resolver` and `extra-deps` values, if relevant. If you run+`stack freeze --snapshot`, it will provide you with an update snapshot file.++New contents will be printed to `stdout` instead of modifying your existing+files to avoid mutation of user-created files.++## Snapshot location++There are essentially four different ways of specifying a snapshot+location:++* Via a compiler version, which is a "compiler only" snapshot. This+  could be, e.g., `resolver: ghc-8.6.5`.+* Via a URL pointing to a snapshot configuration file, e.g. `resolver: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2018/8/21.yaml`+* Via a local file path pointing to a snapshot configuration file, e.g. `resolver: my-local-snapshot.yaml`+* Via a _convenience synonym_, which provides a short form for some+  common URLs. These are:+    * Github: `github:user/repo:path` is treated as `https://raw.githubusercontent.com/user/repo/master/path`+    * LTS Haskell: `lts-X.Y` is treated as `github:commercialhaskell/stackage-snapshots:lts/X/Y.yaml`+    * Stackage Nightly: `nightly-YYYY-MM-DD` is treated as `github:commercialhaskell/stackage-snapshots:nightly/YYYY/M/D.yaml`++For safer, more reproducible builds, you can optionally specify a URL+together with a cryptographic hash of its content, e.g.:++```yaml+resolver:+  size: 499143+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/0.yaml+  sha256: 781ea577595dff08b9c8794761ba1321020e3e1ec3297fb833fe951cce1bee11+```++Where the `size` is the number of bytes in the file, and `sha256` is+its SHA256 hash. This information can automatically be generated with+the [`stack freeze`](#freeze-command) command.++## Package location++Pantry supports three types of package locations:++* Hackage packages+* Repositories+* Archives++All three of these formats support optional tree metadata to be added,+which can be used for reproducibility and faster downloads. This+information can automatically be generated with the [`stack+freeze`](#freeze-command) command.++### Hackage++Packages can be stated by a name/version combination. The basic syntax+for this is:++```yaml+extra-deps:+- acme-missiles-0.3+```++Using this syntax, the most recent Cabal file revision available will+be used. For more reproducibility of builds, it is recommended to+state the SHA256 hash of the cabal file contents as well, like this:++```yaml+extra-deps:+- acme-missiles-0.3@sha256:2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1+```++Or, better yet, including the cabal file size too:++```yaml+extra-deps:+- acme-missiles-0.3@sha256:2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1,631+```++Or a specific revision number, with `0` being the original file:++```yaml+extra-deps:+- acme-missiles-0.3@rev:0+```++Note that specifying via SHA256 is slightly more resilient in that it+does not rely on correct ordering in the package index, while revision+number is likely simpler to use. In practice, both should guarantee+equally reproducible build plans.++Finally, you can include the Pantry tree information. The following+was generated with `stack freeze`:++```yaml+- hackage: acme-missiles-0.3@sha256:2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1,613+  pantry-tree:+    size: 226+    sha256: 614bc0cca76937507ea0a5ccc17a504c997ce458d7f2f9e43b15a10c8eaeb033+```++### Git and Mercurial repos++You can give a Git or Mercurial repo at a specific commit, and Stack+will clone that repo.++```yaml+extra-deps:+- git: git@github.com:commercialhaskell/stack.git+  commit: 6a86ee32e5b869a877151f74064572225e1a0398+- git: git@github.com:snoyberg/http-client.git+  commit: "a5f4f3"+- hg: https://example.com/hg/repo+  commit: da39a3ee5e6b4b0d3255bfef95601890afd80709+```++__NOTE__ It is highly recommended that you only use SHA1 values for a+Git or Mercurial commit. Other values may work, but they are not+officially supported, and may result in unexpected behavior (namely,+Stack will not automatically pull to update to new versions).+Another problem with this is that your build will not be deterministic,+because when someone else tries to build the project they can get a+different checkout of the package.++A common practice in the Haskell world is to use "megarepos", or+repositories with multiple packages in various subdirectories. Some+common examples include [wai](https://github.com/yesodweb/wai/) and+[digestive-functors](https://github.com/jaspervdj/digestive-functors). To+support this, you may also specify `subdirs` for repositories, e.g.:++```yaml+extra-deps:+- git: git@github.com:yesodweb/wai+  commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f+  subdirs:+  - auto-update+  - wai+```++Since v1.7.1, you can specify packages from GitHub repository name using `github`:++```yaml+extra-deps:+- github: snoyberg/http-client+  commit: a5f4f30f01366738f913968163d856366d7e0342+```++If unspecified, `subdirs` defaults to `['.']` meaning looking for a+package in the root of the repo.  Note that if you specify a value of+`subdirs`, then `'.'` is _not_ included by default and needs to be+explicitly specified if a required package is found in the top-level+directory of the repository.++Using the `stack freeze` command will add in additional information,+including not only the Pantry tree hash, but also package metadata+which can allow Stack to work faster by bypassing cabal file+parses. For example, this:++```yaml+extra-deps:+- git: git@github.com:yesodweb/wai+  commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f+  subdirs:+  - auto-update+  - wai+```++Would be converted into:++```yaml+extra-deps:+- subdir: auto-update+  cabal-file:+    size: 1219+    sha256: c07b2b1a2df1199f83eef819ac9bb067567e100b60586a52f8b92fc733ae3a6d+  name: auto-update+  version: 0.1.2.1+  git: git@github.com:yesodweb/wai+  pantry-tree:+    size: 687+    sha256: 26377897f35ccd3890b4405d72523233717afb04d62f2d36031bf6b18dcef74f+  commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f+- subdir: wai+  cabal-file:+    size: 1717+    sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056+  name: wai+  version: 3.0.2.3+  git: git@github.com:yesodweb/wai+  pantry-tree:+    size: 10299+    sha256: ce33fddab13592c847fbd7acd1859dfcbb9aeb6c212db3cee27c909fa3f3ae44+  commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f+```++#### Limited [git-annex](https://git-annex.branchable.com) support++Pantry does not support [git-annex](https://git-annex.branchable.com). This is+because `git archive` does not handle symbolic links outside the work tree. It+is still possible to use repositories which use git-annex but do not require the+annex files for the package to be built.++To do so, ensure that any files or directories stored by git-annex are marked+[export-ignore](https://git-scm.com/docs/git-archive#Documentation/git-archive.txt-export-ignore)+in the `.gitattributes` file in the repository. See+[#4579](https://github.com/commercialhaskell/stack/issues/4579) for more+information.++For example, if the directory `fonts/` is controlled by git-annex, use the+following line.++```gitattributes+fonts export-ignore+```++### Archives (HTTP(S) or local filepath)++You can use HTTP and HTTPS URLs and local filepaths referring to+either tarballs or ZIP files.++__NOTE__ Stack assumes that these files never change after downloading+to avoid needing to make an HTTP request on each build. Use hashes to+provide more security.++```yaml+extra-deps:+- https://example.com/foo/bar/baz-0.0.2.tar.gz+- archive: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip+  subdirs:+  - wai+  - warp+- archive: ../acme-missiles-0.3.tar.gz+  sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b+```++With the `stack freeze` command, this would be replaced with:++```yaml+extra-deps:+- size: 1540+  url: https://hackage.haskell.org/package/acme-dont-1.1.tar.gz+  cabal-file:+    size: 602+    sha256: 8264ad3e5113d3e0417b46e71d5a9c0914a1f03b5b81319cc329f1dc0f49b96c+  name: acme-dont+  version: '1.1'+  sha256: c32231ff8548bccd4f3bafcc9b1eb84947a2e5e0897c50c048e0e7609fc443ce+  pantry-tree:+    size: 206+    sha256: 79dbeddaf0fd507611687cefe9511c8fda489849fb0cac3894925716936290b2+- size: 285152+  subdir: wai+  url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip+  cabal-file:+    size: 1717+    sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056+  name: wai+  version: 3.0.2.3+  sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba+  pantry-tree:+    size: 10296+    sha256: ce431f1a22fcda89375ba5e35e53aee968eea23d1124fcba7cb9eae426daa2db+- size: 285152+  subdir: warp+  url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip+  cabal-file:+    size: 6648+    sha256: e3f01fd7417af923fd30962e9e6a4fe4de41ebc5e02af9819067fed79c9c6575+  name: warp+  version: 3.0.13.1+  sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba+  pantry-tree:+    size: 4292+    sha256: d6b1def306a042b5fc500930302533a3ea828e916c99cbd82c0b7e2c4e3a8e09+- size: 1442+  filepath: acme-missiles-0.3.tar.gz+  cabal-file:+    size: 613+    sha256: 2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1+  name: acme-missiles+  version: '0.3'+  sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b+  pantry-tree:+    size: 226+    sha256: 614bc0cca76937507ea0a5ccc17a504c997ce458d7f2f9e43b15a10c8eaeb033+```++## Snapshots++_NOTE_ Stack has supported custom snapshots properly since version+1.6. In version 1.11, the support for snapshots was moved to Pantry,+and Stackage snapshots have moved over to using the same+format. Therefore, there is no longer such a thing as "custom+snapshots," there are simply "snapshots." Pantry snapshots follow the+same format as Stack 1.6 "custom snapshots."++Snapshots provide a list of packages to use, along with flags,+ghc-options, and a few other settings. Snapshots may extend any other+snapshot that can be specified in a `resolver` field. The packages+specified follow the same syntax mentioned above for+dependencies. Unlike `extra-deps`, however, no support for local+directories is available in snapshots to ensure reproducibility.++```yaml+resolver: lts-8.21 # Inherits GHC version and package set+compiler: ghc-8.0.1 # Overwrites GHC version in the resolver, optional++# Additional packages, follows extra-deps syntax+packages:+- unordered-containers-0.2.7.1+- hashable-1.2.4.0+- text-1.2.2.1++# Override flags, can also override flags in the parent snapshot+flags:+  unordered-containers:+    debug: true++# Packages from the parent snapshot to ignore+drop-packages:+- wai-extra++# Packages which should be hidden (affects script command's import+# parser+hidden:+  wai: true+  warp: false++# Set GHC options for specific packages+ghc-options:+  warp:+  - -O2+```++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: 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.++Running the `stack freeze --snapshot` command yields the following+output:++```yaml+flags:+  unordered-containers:+    debug: true+ghc-options:+  warp:+  - -O2+packages:+- hackage: unordered-containers-0.2.7.1@sha256:7a1ceb6d88c0f16ec417f28dac16f6dc7b10e88fbb536a74d84941ad2f57b74b,4367+  pantry-tree:+    size: 1286+    sha256: 8a8f745cacae3c11a9c6e6c2fcefc95a13d0c153a8e14b4d28485db1b59d9ef3+- hackage: hashable-1.2.4.0@sha256:33a49b3ea87cc4a0c89a4fd48f19e4807d8c620aff710a048a28cf7d9c9b4620,4271+  pantry-tree:+    size: 1325+    sha256: cb05c31a8ec43f727004e5a6c8e35ff92e0515855a85cb01fa73623683ee4b33+- hackage: text-1.2.2.1@sha256:1c6ffad395d1674915cc9fda1d3b8f202ddcbfda7c341eb8bd99de67d3283bf9,5724+  pantry-tree:+    size: 7376+    sha256: ac2601c49cf7bc0f5d66b2793eddc8352f51a6ee989980827a0d0d8169700a03+hidden:+  warp: false+  wai: true+drop-packages:+- wai-extra+compiler: ghc-8.0.1+resolver:+  size: 515969+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/8/21.yaml+  sha256: 2ec73d520d3e55cb753eaca11a72a9ce95bd9ba7ccaf16de1150d0130a50a5a1+```++### 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+flags:+  text:+    developer: true+```++## Updating frozen information++Suppose you're depending on `foo-1.2.3` from Hackage, and have used `stack+freeze` on your file. Now you'd like to upgrade to `foo-1.2.4`. Doing so+requires you to:++* Change the version number specified to `1.2.4`+* Remove any freeze information that may conflict, like cabal file info, pantry tree, etc+* Rerun the `stack freeze` command to generate the new freeze information
doc/shell_autocompletion.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # Shell Auto-completion
doc/stack_yaml_vs_cabal_package_file.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # stack.yaml vs cabal package file
doc/travis_ci.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # Travis CI
doc/yaml_configuration.md view
@@ -1,4 +1,4 @@-<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://rawgit.com/commercialhaskell/stack/master/doc/img/hidden-warning.svg"></a></div>+<div class="hidden-warning"><a href="https://docs.haskellstack.org/"><img src="https://cdn.jsdelivr.net/gh/commercialhaskell/stack/doc/img/hidden-warning.svg"></a></div>  # YAML Configuration @@ -49,6 +49,8 @@  ### resolver +> Note: Starting with **Stack 2.0**, `snapshot` is accepted as a synonym for `resolver`. Only one of these fields is permitted, not both.+ Specifies which snapshot is to be used for this project. A snapshot defines a GHC version, a number of packages available for installation, and various settings like build flags. It is called a@@ -60,210 +62,159 @@ * 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](custom_snapshot.md)+* Custom snapshot, via a URL or relative file path. (See [pantry docs](pantry.md) for more information.)  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. -### packages and extra-deps--_NOTE_ The contents of this section have changed significantly since-extensible snapshots were implemented (see:-[writeup](https://www.fpcomplete.com/blog/2017/07/stacks-new-extensible-snapshots)-and-[PR #3249](https://github.com/commercialhaskell/stack/pull/3249)). Most-old syntax is still supported with newer versions of Stack, but will-not be documented here. Instead, this section contains the recommended-syntax as of Stack v1.6.0.--There are two types of packages that can be defined in your-`stack.yaml` file:--* __Project packages__, those which you are actually working on in-  your current project. These are local file paths in your project-  directory.-* __Extra dependencies__, which are packages provided locally on top-  of the snapshot definition of available packages. These can come-  from Hackage (or an alternative package index you've defined, see-  [package-indices](#package-indices)), an HTTP(S) or local archive, a-  Git or Mercurial repository, or a local file path.+Since Stack 1.11, the resolver field corresponds to a Pantry snapshot+location. See [the docs on pantry](pantry.md) for more information. -These two sets of packages are both installed into your local package-database within your project. However, beyond that, they are-completely different:+### packages -* Project packages will be built by default with a `stack build`-  without specific targets. Extra dependencies will only be built if-  they are depended upon.-* Test suites and benchmarks may be run for project packages. They are-  never run for extra dependencies.+_NOTE_ Beginning with Stack 1.11, Stack has moved over to Pantry for+managing extra-deps, and has removed some legacy syntax for specifying+dependencies in `packages`. See some conversion notes below. -The `packages` key is a simple list of file paths, which will be-treated as relative to the directory containing your `stack.yaml`-file. For example:+A list of packages that are part of your local project. These are+specified via paths to local directories. The paths are considered+relative to the directory containing the `stack.yaml` file. For+example, if your `stack.yaml` is located at `/foo/bar/stack.yaml`, and+you have:  ```yaml packages:-- .-- dir1/dir2+- hello+- there/world ``` -Each package directory or location specified must have a valid cabal-file or hpack `package.yaml` file present. Note that the-subdirectories of the directory are not searched for cabal-files. Subdirectories will have to be specified as independent items-in the list of packages.+Your configuration means "I have packages in `/foo/bar/hello` and+`/foo/bar/there/world`. -When the `packages` field is not present, it defaults to looking for a package-in the project's root directory:+If these packages should be treated as dependencies instead, specify+them in `extra-deps`, described below. +The `packages` field is _optional_. If omitted, it is treated as:+ ```yaml packages: - . ``` -The `extra-deps` key is given a list of all extra dependencies. If-omitted, it is taken as the empty list, e.g.:+Each package directory specified must have a valid cabal file or hpack+`package.yaml` file present. Note that the subdirectories of the+directory are not searched for cabal files. Subdirectories will have+to be specified as independent items in the list of packages. -```yaml-extra-deps: []-```+Meaning that your project has exactly one package, and it is located+in the current directory. -It supports four different styles of values:+Project packages are different from snapshot dependencies (via+`resolver`) and extra dependencies (via `extra-deps`) in multiple+ways, e.g.: -#### Package index+* Project packages will be built by default with a `stack build`+  without specific targets. Dependencies will only be built if+  they are depended upon.+* Test suites and benchmarks may be run for project packages. They are+  never run for extra dependencies. -Packages can be stated by a name/version combination, which will be-looked up in the package index (by default, Hackage). The basic syntax-for this is:+__Legacy syntax__ Prior to Stack 1.11, it was possible to specify+dependencies in your `packages` configuration value as well. This+support has been removed to simplify the file format. Instead, these+values should be moved to `extra-deps`. As a concrete example, you+would convert:  ```yaml-extra-deps:-- acme-missiles-0.3-```--Using this syntax, the most recent Cabal file revision available will-be used. For more reproducibility of builds, it is recommended to-state the SHA256 hash of the cabal file contents as well, like this:+packages:+- .+- location:+    git: https://github.com/bitemyapp/esqueleto.git+    commit: 08c9b4cdf977d5bcd1baba046a007940c1940758+  extra-dep: true+- location:+    git: https://github.com/yesodweb/wai.git+    commit: 6bf765e000c6fd14e09ebdea6c4c5b1510ff5376+    subdirs:+      - wai-extra+  extra-dep: true -```yaml extra-deps:-- acme-missiles-0.3@sha256:2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1+  - streaming-commons-0.2.0.0+  - time-1.9.1+  - yesod-colonnade-1.3.0.1+  - yesod-elements-1.1 ``` -Or a specific revision number, with `0` being the original file:+into  ```yaml-extra-deps:-- acme-missiles-0.3@rev:0-```--Note that specifying via SHA256 is slightly more resilient in that it-does not rely on correct ordering in the package index, while revision-number is likely simpler to use. In practice, both should guarantee-equally reproducible build plans.--#### Local file path--Like `packages`, local file paths can be used in `extra-deps`, and-will be relative to the directory containing the `stack.yaml` file.+packages:+- . -```yaml extra-deps:-- vendor/somelib-```--Note that if a local directory can be parsed as a package identifier,-Stack will treat it as a package identifier. In other words, if you-have a local directory named `foo-1.2.3`, instead of:--```yaml-extra-deps:-- foo-1.2.3+  - streaming-commons-0.2.0.0+  - time-1.9.1+  - yesod-colonnade-1.3.0.1+  - yesod-elements-1.1+  - git: https://github.com/bitemyapp/esqueleto.git+    commit: 08c9b4cdf977d5bcd1baba046a007940c1940758+  - git: https://github.com/yesodweb/wai.git+    commit: 6bf765e000c6fd14e09ebdea6c4c5b1510ff5376+    subdirs:+      - wai-extra ``` -You should use the following to be explicit:+And, in fact, the `packages` value could be left off entirely since+it's using the default value. -```yaml-extra-deps:-- ./foo-1.2.3-```+### extra-deps -#### Git and Mercurial repos+This field allows you to specify extra dependencies on top of what is+defined in your snapshot (specified in the `resolver` field mentioned+above). These dependencies may either come from a local file path or a+Pantry package location. -You can give a Git or Mercurial repo at a specific commit, and Stack-will clone that repo.+For the local file path case, the same relative path rules as apply to+`packages` apply. -```yaml-extra-deps:-- git: git@github.com:commercialhaskell/stack.git-  commit: 6a86ee32e5b869a877151f74064572225e1a0398-- git: git@github.com:snoyberg/http-client.git-  commit: "a5f4f3"-- hg: https://example.com/hg/repo-  commit: da39a3ee5e6b4b0d3255bfef95601890afd80709-```+Pantry package locations allow you to include dependencies from three+different kinds of sources: -__NOTE__ It is highly recommended that you only use SHA1 values for a-Git or Mercurial commit. Other values may work, but they are not-officially supported, and may result in unexpected behavior (namely,-Stack will not automatically pull to update to new versions).-Another problem with this is that your build will not be deterministic,-because when someone else tries to build the project they can get a-different checkout of the package.+* Hackage+* Archives (tarballs or zip files, either local or over HTTP(S))+* Git or Mercurial repositories -A common practice in the Haskell world is to use "megarepos", or-repositories with multiple packages in various subdirectories. Some-common examples include [wai](https://github.com/yesodweb/wai/) and-[digestive-functors](https://github.com/jaspervdj/digestive-functors). To-support this, you may also specify `subdirs` for repositories, e.g.:+Here's an example using all of the above:  ```yaml extra-deps:-- git: git@github.com:yesodweb/wai-  commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f+- vendor/hashable+- streaming-commons-0.2.0.0+- time-1.9.1+- yesod-colonnade-1.3.0.1+- yesod-elements-1.1+- git: https://github.com/bitemyapp/esqueleto.git+  commit: 08c9b4cdf977d5bcd1baba046a007940c1940758+- url: https://github.com/yesodweb/wai/archive/6bf765e000c6fd14e09ebdea6c4c5b1510ff5376.tar.gz   subdirs:-  - auto-update-  - wai-```--Since v1.7.1, you can specify packages from GitHub repository name using `github`:--```yaml-extra-deps:-- github: snoyberg/http-client-  commit: a5f4f30f01366738f913968163d856366d7e0342+    - wai-extra+- github: snoyberg/conduit+  commit: 2e3e41de93821bcfe8ec6210aeca21be3f2087bf+  subdirs:+    - network-conduit-tls ``` -If unspecified, `subdirs` defaults to `['.']` meaning looking for a-package in the root of the repo..  Note that if you specify a value of-`subdirs`, then `'.'` is _not_ included by default and needs to be-explicitly specified if a required package is found in the top-level-directory of the repository.--#### Archives (HTTP(S) or local filepath)--This one's pretty straightforward: you can use HTTP and HTTPS URLs and-local filepaths referring to either tarballs or ZIP files.--__NOTE__ Stack assumes that these files never change after downloading-to avoid needing to make an HTTP request on each build.+If no `extra-deps` value is provided, it defaults to an empty list,+e.g.:  ```yaml-extra-deps:-- https://example.com/foo/bar/baz-0.0.2.tar.gz-- archive: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip-  subdirs:-  - wai-  - warp-- archive: ../acme-missiles-0.3.tar.gz-  sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b+extra-deps: [] ``` -Note that HTTP(S) URLs also support `subdirs` like repos to allow for-archives of megarepos. In order to leverage this, use `location:-http://...`.+For more information on the format for specifying dependencies, please+see [the Pantry docs](pantry.md).  ### flags @@ -278,48 +229,29 @@ If a specified flag is different than the one specified for a snapshot package, then the snapshot package will automatically be promoted to be an extra-dep. -### image--The image settings are used for the creation of container images using-`stack image container`, e.g.--```yaml-image:-  containers:-    - base: "fpco/stack-build"-      add:-        static: /data/static-```--`base` is the docker image that will be used to built upon. The `add` lines-allow you to add additional directories to your image. You can specify the name-of the image using `name` (otherwise it defaults to the same as your project).-You can also specify `entrypoints`. By default all your executables are placed-in `/usr/local/bin`, but you can specify a list using `executables` to only add-some.+### drop-packages -When you specify `entrypoints`, multiple containers will be built:  a project-container, and one container for each entrypoint.+Packages which, when present in the snapshot specified in `resolver`,+should not be included in our package. This can be used for a few+different purposes, e.g.: -For example the following configuration:+* Ensure that packages you don't want used in your project cannot be+  used in a `package.yaml` file (e.g., for license reasons)+* Prevent overriding of a global package like `Cabal`. For more+  information, see+  [stackage#4425](https://github.com/commercialhaskell/stackage/issues/4425)+* When using a custom GHC build, avoid incompatible packages (see+  [this+  comment](https://github.com/commercialhaskell/stack/pull/4655#issuecomment-477954429)).  ```yaml-image:-  containers:-  - name: myproject-    base: fpco/stack-run-    add:-      production/app-backend/conf/: /etc/app-backend-    entrypoints:-    - app-backend+drop-packages:+- Cabal+- buggy-package+- package-with-unacceptable-license ``` -will build one container tagged `myproject:latest` which contains the project-including the `/etc/app-backend` configuration data.--Another container tagged `myproject-app-backend:latest` based on the `myproject:latest`-will additionally contain the logic for starting the `app-backend` entrypoint.-+Since Stack 2.0  ### user-message @@ -369,12 +301,6 @@  Default: `true` -### latest-snapshot-url--URL providing a JSON with information on the latest LTS and Nightly snapshots, used for automatic project configuration.--Default: `https://www.stackage.org/download/snapshots.json`- ### local-bin-path  Target directory for `stack install` and `stack build --copy-bins`.@@ -383,49 +309,44 @@  ### package-indices -```yaml-package-indices:-- name: Hackage-  download-prefix: https://s3.amazonaws.com/hackage.fpcomplete.com/package/--  # HTTP location of the package index-  http: https://s3.amazonaws.com/hackage.fpcomplete.com/01-index.tar.gz+Since Stack 1.11, this field may only be used to specify a single+package index, which must use the Hackage Security format. For the+motivation for this change, please see [issue #4137](https://github.com/commercialhaskell/stack/issues/4137).+Therefore, this field is most useful for providing an alternate+Hackage mirror either for: -  # Or, if using Hackage Security below, give the root URL:-  http: https://s3.amazonaws.com/hackage.fpcomplete.com/+* Bypassing a firewall+* Faster download speeds -  # optional fields, both default to false-  require-hashes: false+The following is the default setting for this field: -  # Starting with stack 1.4, we default to using Hackage Security+```yaml+package-indices:+- download-prefix: https://hackage.haskell.org/   hackage-security:-    keyids: ["deadbeef", "12345"] # list of all approved keys+    keyids:+    - 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d+    - 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42+    - 280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833+    - 2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201+    - 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3+    - 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921+    - 772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d+    - aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9+    - fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0     key-threshold: 3 # number of keys required-``` -One thing you should be aware of: if you change the contents of package-version-combination by setting a different package index, this *can* have an effect on-other projects by installing into your shared snapshot database.--Note that older versions of Stack supported Git-based indices. This feature has since been removed. A line such as:--```yaml-git: https://github.com/commercialhaskell/all-cabal-hashes.git-gpg-verify: false+    # ignore expiration date, see https://github.com/commercialhaskell/stack/pull/4614+    ignore-expiry: no ``` -Will now be ignored.--__IMPORTANT__ Hackage and its mirrors typically have two index files-available: `00-index.tar.gz` and `01-index.tar.gz`. The former is a-legacy file for backwards compatibility. It does not contain the cabal-file revisions produced by Hackage, and therefore _will not work_ with-most snapshots. Instead, you need to use `01-index.tar.gz` to ensure-that exact revisions can be found, ensuring more reproducible builds.+If you provide a replacement index which does not mirror Hackage, it+is likely that you'll end up with significant breakage, such as most+snapshots failing to work.  ### system-ghc -Enables or disables using the GHC available on the PATH.+Enables or disables using the GHC available on the PATH. (Make sure PATH is explicit, i.e., don't use ~.) 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`.@@ -475,10 +396,10 @@ ```  Since these are system-dependent absolute paths, it is recommended that you-specify these in your `config.yaml` within the stack root (usually, `~/.stack`).-If you control the build environment in your project's ``stack.yaml``, perhaps-through docker or other means, then it may well make sense to include these-there as well.+specify these in your `config.yaml` within the stack root (usually, `~/.stack`+or, on Windows, `%LOCALAPPDATA%\Programs\stack`). If you control the build+environment in your project's ``stack.yaml``, perhaps through docker or other+means, then it may well make sense to include these there as well.   ### with-gcc@@ -529,6 +450,80 @@ compiler-check: match-exact ``` +#### Building GHC from source (experimental)++(Since 2.0)++Stack supports building the GHC compiler from source. The version to build and+to use is defined by a a Git commit ID and an Hadrian "flavour" (Hadrian is the+build system of GHC) with the following syntax:++```yaml+compiler: ghc-git-COMMIT-FLAVOUR+```++In the following example the commit ID is "5be7ad..." and the flavour is+"quick":++```yaml+compiler: ghc-git-5be7ad7861c8d39f60b7101fd8d8e816ff50353a-quick+```++By default the code is retrieved from the main GHC repository. If you want to+select another repository, set the "compiler-repository" option:++```yaml+compiler-repository: git://my/ghc/repository+# default+# compiler-repository: https://gitlab.haskell.org/ghc/ghc.git+```++Note that Stack doesn't check the compiler version when it uses a compiler built+from source. Moreover it is assumed that the built compiler is recent enough as+Stack doesn't enable any known workaround to make older compilers work.++Building the compiler can take a very long time (more than one hour). Hint: for+faster build times, use Hadrian flavours that disable documentation generation.++#### Global packages++The GHC compiler you build from sources may depend on unreleased versions of+some global packages (e.g. Cabal). It may be an issue if a package you try to+build with this compiler depends on such global packages because Stack may not+be able to find versions of those packages (on Hackage, etc.) that are+compatible with the compiler.++The easiest way to deal with this issue is to drop the offending packages as+follows. Instead of using the packages specified in the resolver, the global+packages bundled with GHC will be used.++```yaml+drop-packages:+- Cabal+- ...+```++Another way to deal with this issue is to add the relevant packages as+`extra-deps` built from source. To avoid mismatching versions, you can use+exactly the same commit id you used to build GHC as follows:++```+extra-deps:+- git: https://gitlab.haskell.org/ghc/ghc.git+  commit: 5be7ad7861c8d39f60b7101fd8d8e816ff50353a+  subdirs:+    - libraries/Cabal/Cabal+    - libraries/...+```++#### Bootstrapping compiler++Building GHC from source requires a working GHC (known as the bootstrap+compiler). As we use a Stack based version of Hadrian (`hadrian/build.stack.sh` in+GHC sources), the bootstrap compiler is configured into `hadrian/stack.yaml` and+fully managed by Stack.++ ### ghc-options  (Since 0.1.4)@@ -590,6 +585,24 @@ rebuild-ghc-options: true ``` +### configure-options++Options which are passed to the configure step of the Cabal build process.+These can either be set by package name, or using the `$everything`,+`$targets`, and `$locals` special keys. These special keys have the same+meaning as in `ghc-options`.++```yaml+configure-options:+  $everything:+  - --with-gcc+  - /some/path+  my-package:+  - --another-flag+```++(Since 2.0)+ ### ghc-variant  (Since 0.1.5)@@ -617,7 +630,7 @@  (Since 0.1.5) -Allows overriding from where tools like GHC and msys2 (on Windows) are+Allows augmenting from where tools like GHC and msys2 (on Windows) are downloaded. Most useful for specifying locations of custom GHC binary distributions (for use with the [ghc-variant](#ghc-variant) option): @@ -629,14 +642,19 @@         url: "https://example.com/ghc-7.10.2-i386-unknown-mingw32-foo.tar.xz" ``` -Or without using `ghc-variant`:+Or you can point to external setup-info:  ```yaml-setup-info: "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup-2.yaml"+setup-info: "https://example.com/my-stack-setup-info.yaml" ``` -`url` may be either URL or (since 1.2.0) absolute file path.+This may be either URL or (since 1.2.0) absolute file path. +Note that this **adds** the specified setup info metadata to the default.+If you need to **replace** it, use the `stack --setup-info-yaml` command-line+argument instead.  The default setup metadata is in+[stack-setup-2.yaml](https://github.com/commercialhaskell/stackage-content/raw/master/stack/stack-setup-2.yaml).+ ### pvp-bounds  (Since 0.1.5)@@ -788,8 +806,11 @@   cabal-verbose: false   split-objs: false -  # Since 1.8-  interleaved-output: false+  # Since 1.8. Starting with 2.0, the default is true+  interleaved-output: true++  # Since 1.10+  ddump-dir: "" ```  The meanings of these settings correspond directly with the CLI flags of the@@ -854,7 +875,7 @@     author-name: Your Name     author-email: youremail@example.com     category: Your Projects Category-    copyright: 'Copyright (c) 2018 Your Name'+    copyright: 'Copyright (c) 2019 Your Name'     github-username: yourusername ``` @@ -891,21 +912,9 @@  ### ignore-revision-mismatch -Cabal files in packages can be specified via exact revisions to deal-with Hackage revision metadata. The default behavior of Stack (since-1.6.0) is to fail if an exact match is not found. In some cases-(specifically, when using a legacy `00-index.tar.gz` file), users may-wish to allow a mismatch. In such cases, you can change-`ignore-revision-mismatch` from `false` to `true`.--```yaml-ignore-revision-mismatch: false-```--For more information, see-[the Github issue #3520 discussion](https://github.com/commercialhaskell/stack/issues/3520).--Since 1.6.0+This flag was introduced in Stack 1.6, and removed in Stack 1.11 with+the move to Pantry. You will receive a warning if this configuration+value is set.  ### urls @@ -916,13 +925,8 @@ ```yaml urls:   latest-snapshot: https://www.stackage.org/download/snapshots.json-  lts-build-plans: https://raw.githubusercontent.com/fpco/lts-haskell/master/-  nightly-build-plans: https://raw.githubusercontent.com/fpco/stackage-nightly/master/ ``` -**Note:** The `latest-snapshot-url` field has been deprecated in favor of `latest-snapshot`-and will be removed in a future version of `stack`.- ### jobs  Specifies how many build tasks should be run in parallel. This can be overloaded@@ -999,10 +1003,22 @@ msys get installed.  On most systems, this defaults to a folder called `programs`-within the stack root directory. On windows, if the `LOCALAPPDATA` environment-variable exists, then it defaults to `$LOCALAPPDATA/Programs/stack/`, which-follows windows conventions.+within the stack root directory. On Windows, if the `LOCALAPPDATA` environment+variable exists, then it defaults to `%LOCALAPPDATA%\Programs\stack`, which+follows Windows' conventions. +__NOTE__: On Windows, if there is a space character in the `%LOCALAPPDATA%` path+(which may be the case if the relevant user account name and its corresponding+user profie path have a space) this may cause problems with building packages+that make use of the GNU project's `autoconf` package and `configure` shell+script files. That may be the case particularly if there is no corresponding+short name ('8 dot 3' name) for the folder in the path with the space (which may+be the case if '8 dot 3' names have been stripped or their creation not enabled+by default). If there are problems building, it will be necessary to override+the default location of stack's programs directory to specify an alternative+path that does not contain space characters. Examples of packages on Hackage+that make use of `configure` are `network` and `process`.+ Since 1.3.0  ### default-template@@ -1011,6 +1027,20 @@ specified. The default is called `new-template`. The other templates are listed in [the stack-templates repo](https://github.com/commercialhaskell/stack-templates/). +### color++This option specifies when to use color in output. The option is used as+`color: <WHEN>`, where `<WHEN>` is 'always', 'never', or 'auto'. On Windows+versions before Windows 10, for terminals that do not support color codes, the+default is 'never'; color may work on terminals that support color codes.++The color use can also be set at the command line using the equivalent+`--color=<WHEN>` global option. Color use set at the command line takes+precedence over that set in a yaml configuration file.++(The British English spelling (colour) is also accepted. In yaml configuration+files, the American spelling is the alternative that has priority.)+ ### stack-colors  Stack uses styles to format some of its output. The default styles do not work@@ -1039,4 +1069,45 @@ ```yaml stack-colors: error=31:good=32:shell=35:dir=34:recommendation=32:target=95:module=35:package-component=95 ```-The styles can also be set at the command line using the equivalent `--stack-colors=<STYLES>` global option. Styles set at the command line take precedence over those set in a yaml configuration file.+The styles can also be set at the command line using the equivalent `--stack-colors=<STYLES>`+global option. Styles set at the command line take precedence over those set in+a yaml configuration file.++(The British English spelling (colour) is also accepted. In yaml configuration+files, the American spelling is the alternative that has priority.)++### hide-source-paths++Stack will use the `-fhide-source-paths` option by default for GHC >= 8.2, unless this+option is set to `false` as in the following example:++```yaml+hide-source-paths: false+```++Build output when enabled:++```+...+[1 of 2] Compiling Lib+[2 of 2] Compiling Paths_test_pr+...+```++Build output when disabled:++```+...+[1 of 2] Compiling Lib              ( src/Lib.hs, .stack-work/dist/x86_64-linux-tinfo6/Cabal-2.4.0.1/build/Lib.o )+...+```++### recommend-stack-upgrade++When Stack notices that a new version of Stack is available, should it notify the user?++```yaml+recommend-stack-upgrade: true+```++Since 2.0
src/Control/Concurrent/Execute.hs view
@@ -16,7 +16,6 @@ import           Stack.Prelude import           Data.List (sortBy) import qualified Data.Set                 as Set-import           Stack.Types.PackageIdentifier  data ActionType     = ATBuild
− src/Data/Aeson/Extended.hs 
@@ -1,175 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}---- | Extensions to Aeson parsing of objects.-module Data.Aeson.Extended (-    module Export-  -- * Extended failure messages-  , (.:)-  , (.:?)-  -- * JSON Parser that emits warnings-  , JSONWarning (..)-  , WarningParser-  , WithJSONWarnings (..)-  , withObjectWarnings-  , jsonSubWarnings-  , jsonSubWarningsT-  , jsonSubWarningsTT-  , logJSONWarnings-  , noJSONWarnings-  , tellJSONField-  , unWarningParser-  , (..:)-  , (..:?)-  , (..!=)-  ) where--import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell)-import Data.Aeson as Export hiding ((.:), (.:?))-import qualified Data.Aeson as A-import Data.Aeson.Types hiding ((.:), (.:?))-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Set as Set-import Data.Text (unpack)-import qualified Data.Text as T-import Generics.Deriving.Monoid (mappenddefault, memptydefault)-import Stack.Prelude---- | Extends @.:@ warning to include field name.-(.:) :: FromJSON a => Object -> Text -> Parser a-(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: p)-{-# INLINE (.:) #-}---- | Extends @.:?@ warning to include field name.-(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a)-(.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? p)-{-# INLINE (.:?) #-}---- | 'WarningParser' version of @.:@.-(..:)-    :: FromJSON a-    => Object -> Text -> WarningParser a-o ..: k = tellJSONField k >> lift (o .: k)---- | 'WarningParser' version of @.:?@.-(..:?)-    :: FromJSON a-    => Object -> Text -> WarningParser (Maybe a)-o ..:? k = tellJSONField k >> lift (o .:? k)---- | 'WarningParser' version of @.!=@.-(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a-wp ..!= d =-    flip mapWriterT wp $-    \p ->-         do a <- fmap snd p-            fmap (, a) (fmap fst p .!= d)---- | Tell warning parser about an expected field, so it doesn't warn about it.-tellJSONField :: Text -> WarningParser ()-tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key})---- | 'WarningParser' version of 'withObject'.-withObjectWarnings :: String-                   -> (Object -> WarningParser a)-                   -> Value-                   -> Parser (WithJSONWarnings a)-withObjectWarnings expected f =-    withObject expected $-    \obj ->-         do (a,w) <- runWriterT (f obj)-            let unrecognizedFields =-                    Set.toList-                        (Set.difference-                             (Set.fromList (HashMap.keys obj))-                             (wpmExpectedFields w))-            return-                (WithJSONWarnings a-                    (wpmWarnings w ++-                     case unrecognizedFields of-                         [] -> []-                         _ -> [JSONUnrecognizedFields expected unrecognizedFields]))---- | Convert a 'WarningParser' to a 'Parser'.-unWarningParser :: WarningParser a -> Parser a-unWarningParser wp = do-    (a,_) <- runWriterT wp-    return a---- | Log JSON warnings.-logJSONWarnings-    :: (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m)-    => FilePath -> [JSONWarning] -> m ()-logJSONWarnings fp =-    mapM_ (\w -> logWarn ("Warning: " <> fromString fp <> ": " <> displayShow w))---- | Handle warnings in a sub-object.-jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a-jsonSubWarnings f = do-    WithJSONWarnings result warnings <- f-    tell-        (mempty-         { wpmWarnings = warnings-         })-    return result---- | Handle warnings in a @Traversable@ of sub-objects.-jsonSubWarningsT-    :: Traversable t-    => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)-jsonSubWarningsT f =-    mapM (jsonSubWarnings . return) =<< f---- | Handle warnings in a @Maybe Traversable@ of sub-objects.-jsonSubWarningsTT-    :: (Traversable t, Traversable u)-    => WarningParser (u (t (WithJSONWarnings a)))-    -> WarningParser (u (t a))-jsonSubWarningsTT f =-    mapM (jsonSubWarningsT . return) =<< f---- Parsed JSON value without any warnings-noJSONWarnings :: a -> WithJSONWarnings a-noJSONWarnings v = WithJSONWarnings v []---- | JSON parser that warns about unexpected fields in objects.-type WarningParser a = WriterT WarningParserMonoid Parser a---- | Monoid used by 'WarningParser' to track expected fields and warnings.-data WarningParserMonoid = WarningParserMonoid-    { wpmExpectedFields :: !(Set Text)-    , wpmWarnings :: [JSONWarning]-    } deriving Generic-instance Semigroup WarningParserMonoid where-    (<>) = mappenddefault-instance Monoid WarningParserMonoid where-    mempty = memptydefault-    mappend = (<>)-instance IsString WarningParserMonoid where-    fromString s = mempty { wpmWarnings = [fromString s] }---- Parsed JSON value with its warnings-data WithJSONWarnings a = WithJSONWarnings a [JSONWarning]-    deriving (Eq, Generic, Show)-instance Functor WithJSONWarnings where-    fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w-instance Monoid a => Semigroup (WithJSONWarnings a) where-    (<>) = mappenddefault-instance Monoid a => Monoid (WithJSONWarnings a) where-    mempty = memptydefault-    mappend = (<>)---- | Warning output from 'WarningParser'.-data JSONWarning = JSONUnrecognizedFields String [Text]-                 | JSONGeneralWarning !Text-    deriving Eq-instance Show JSONWarning where-    show (JSONUnrecognizedFields obj [field]) =-        "Unrecognized field in " <> obj <> ": " <> T.unpack field-    show (JSONUnrecognizedFields obj fields) =-        "Unrecognized fields in " <> obj <> ": " <> T.unpack (T.intercalate ", " fields)-    show (JSONGeneralWarning t) = T.unpack t-instance IsString JSONWarning where-  fromString = JSONGeneralWarning . T.pack
src/Data/Attoparsec/Interpreter.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-} {- |  This module implements parsing of additional arguments embedded in a       comment when stack is invoked as a script interpreter @@ -58,12 +57,10 @@ import           Data.Attoparsec.Text ((<?>)) import qualified Data.Attoparsec.Text as P import           Data.Char (isSpace)-import           Data.Conduit+import           Conduit import           Data.Conduit.Attoparsec-import           Data.Conduit.Text (decodeUtf8) import           Data.List (intercalate) import           Data.Text (pack)-import           Stack.Constants import           Stack.Prelude import           System.FilePath (takeExtension) import           System.IO (stderr, hPutStrLn)@@ -120,7 +117,7 @@     parseFile src =          runConduit        $ src-      .| decodeUtf8+      .| decodeUtf8C       .| sinkParserEither (interpreterArgsParser isLiterate stackProgName)      isLiterate = takeExtension file == ".lhs"@@ -147,11 +144,7 @@      decodeError e =       case e of-#if MIN_VERSION_conduit_extra(1,2,0)         ParseError ctxs _ (Position line col _) ->-#else-        ParseError ctxs _ (Position line col) ->-#endif           if null ctxs           then "Parse error"           else ("Expecting " ++ intercalate " or " ctxs)
− src/Data/IORef/RunOnce.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Data.IORef.RunOnce (runOnce) where--import Stack.Prelude--runOnce :: (MonadUnliftIO m, MonadIO n) => m a -> m (n a)-runOnce f = withRunInIO $ \run -> do-    ref <- newIORef Nothing-    return $ liftIO $ do-        mval <- readIORef ref-        case mval of-            Just val -> return val-            Nothing -> do-                val <- run f-                writeIORef ref (Just val)-                return val
− src/Data/Store/VersionTagged.hs 
@@ -1,111 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns #-}--- | Tag a Store instance with structural version info to ensure we're--- reading a compatible format.-module Data.Store.VersionTagged-    ( versionedEncodeFile-    , versionedDecodeOrLoad-    , versionedDecodeFile-    , storeVersionConfig-    ) where--import Stack.Prelude-import qualified Data.ByteString as BS-import qualified Data.Map as M-import qualified Data.Set as S-import Data.Store-import Data.Store.Core (unsafeEncodeWith)-import Data.Store.Version-import Language.Haskell.TH-import Path-import Path.IO (ensureDir)--versionedEncodeFile :: Data a => VersionConfig a -> Q Exp-versionedEncodeFile vc = [e| storeEncodeFile $(encodeWithVersionQ vc) $(decodeWithVersionQ vc) |]--versionedDecodeOrLoad :: Data a => VersionConfig a -> Q Exp-versionedDecodeOrLoad vc = [| versionedDecodeOrLoadImpl $(encodeWithVersionQ vc) $(decodeWithVersionQ vc) |]--versionedDecodeFile :: Data a => VersionConfig a -> Q Exp-versionedDecodeFile vc = [e| versionedDecodeFileImpl $(decodeWithVersionQ vc) |]---- | Write to the given file.-storeEncodeFile :: (Store a, MonadIO m, MonadReader env m, HasCallStack, HasLogFunc env, Eq a)-                => (a -> (Int, Poke ()))-                -> Peek a-                -> Path Abs File-                -> a-                -> m ()-storeEncodeFile pokeFunc peekFunc fp x = do-    let fpt = fromString (toFilePath fp)-    logDebug $ "Encoding " <> fpt-    ensureDir (parent fp)-    let (sz, poker) = pokeFunc x-        encoded = unsafeEncodeWith poker sz-    assert (decodeExWith peekFunc encoded == x) $ liftIO $ BS.writeFile (toFilePath fp) encoded-    logDebug $ "Finished writing " <> fpt---- | Read from the given file. If the read fails, run the given action and--- write that back to the file. Always starts the file off with the--- version tag.-versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadUnliftIO m, MonadReader env m, HasCallStack, HasLogFunc env)-                          => (a -> (Int, Poke ()))-                          -> Peek a-                          -> Path Abs File-                          -> m a-                          -> m a-versionedDecodeOrLoadImpl pokeFunc peekFunc fp mx = do-    let fpt = fromString (toFilePath fp)-    logDebug $ "Trying to decode " <> fpt-    mres <- versionedDecodeFileImpl peekFunc fp-    case mres of-        Just x -> do-            logDebug $ "Success decoding " <> fpt-            return x-        _ -> do-            logDebug $ "Failure decoding " <> fpt-            x <- mx-            storeEncodeFile pokeFunc peekFunc fp x-            return x--versionedDecodeFileImpl :: (Store a, MonadUnliftIO m, MonadReader env m, HasCallStack, HasLogFunc env)-                        => Peek a-                        -> Path loc File-                        -> m (Maybe a)-versionedDecodeFileImpl peekFunc fp = do-    mbs <- liftIO (Just <$> BS.readFile (toFilePath fp)) `catch` \(err :: IOException) -> do-        logDebug ("Exception ignored when attempting to load " <> fromString (toFilePath fp) <> ": " <> displayShow err)-        return Nothing-    case mbs of-        Nothing -> return Nothing-        Just bs ->-            liftIO (Just <$> decodeIOWith peekFunc bs) `catch` \(err :: PeekException) -> do-                 let fpt = fromString (toFilePath fp)-                 logDebug ("Error while decoding " <> fpt <> ": " <> displayShow err <> " (this might not be an error, when switching between stack versions)")-                 return Nothing--storeVersionConfig :: String -> String -> VersionConfig a-storeVersionConfig name hash = (namedVersionConfig name hash)-    { vcIgnore = S.fromList-        [ "Data.Vector.Unboxed.Base.Vector GHC.Types.Word"-        , "Data.ByteString.Internal.ByteString"-        ]-    , vcRenames = M.fromList-        [ ( "Data.Maybe.Maybe", "GHC.Base.Maybe")-        , ( "Stack.Types.Compiler.CVActual"-          , "Stack.Types.Compiler.'CVActual"-          )-        , ( "Stack.Types.Compiler.CVWanted"-          , "Stack.Types.Compiler.'CVWanted"-          )-        -- moved in containers 0.5.9.1-        , ( "Data.Map.Internal.Map", "Data.Map.Base.Map")-        , ( "Data.Set.Internal.Set", "Data.Set.Base.Set")-        ]-    }
− src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs 
@@ -1,153 +0,0 @@--- Explicitly disabling due to external code {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}--- Taken from--- https://github.com/well-typed/hackage-security/tree/master/hackage-security-http-client--- to avoid extra dependencies-module Hackage.Security.Client.Repository.HttpLib.HttpClient (-    makeHttpLib-    -- ** Re-exports-  , Manager -- opaque-  ) where--import Control.Exception-import Control.Monad (void)-import Data.ByteString (ByteString)-import Network.URI-import qualified Data.ByteString              as BS-import qualified Data.ByteString.Char8        as BS.C8-import           Network.HTTP.StackClient (Manager)-import qualified Network.HTTP.StackClient     as StackClient--import Hackage.Security.Client hiding (Header)-import Hackage.Security.Client.Repository.HttpLib-import Hackage.Security.Util.Checked-import qualified Hackage.Security.Util.Lens as Lens--{--------------------------------------------------------------------------------  Top-level API--------------------------------------------------------------------------------}---- | Create an 'HttpLib' value from a preexisting 'Manager'.-makeHttpLib :: Manager -> HttpLib-makeHttpLib manager = HttpLib-    { httpGet      = get      manager-    , httpGetRange = getRange manager-    }--{--------------------------------------------------------------------------------  Individual methods--------------------------------------------------------------------------------}--get :: Throws SomeRemoteError-    => Manager-    -> [HttpRequestHeader] -> URI-    -> ([HttpResponseHeader] -> BodyReader -> IO a)-    -> IO a-get manager reqHeaders uri callback = wrapCustomEx $ do-    -- TODO: setUri fails under certain circumstances; in particular, when-    -- the URI contains URL auth. Not sure if this is a concern.-    request' <- StackClient.setUri StackClient.defaultRequest uri-    let request = setRequestHeaders reqHeaders request'-    checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do-      let br = wrapCustomEx $ StackClient.responseBody response-      callback (getResponseHeaders response) br--getRange :: Throws SomeRemoteError-         => Manager-         -> [HttpRequestHeader] -> URI -> (Int, Int)-         -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)-         -> IO a-getRange manager reqHeaders uri (from, to) callback = wrapCustomEx $ do-    request' <- StackClient.setUri StackClient.defaultRequest uri-    let request = setRange from to-                $ setRequestHeaders reqHeaders request'-    checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do-      let br = wrapCustomEx $ StackClient.responseBody response-      case () of-         () | StackClient.responseStatus response == StackClient.partialContent206 ->-           callback HttpStatus206PartialContent (getResponseHeaders response) br-         () | StackClient.responseStatus response == StackClient.ok200 ->-           callback HttpStatus200OK (getResponseHeaders response) br-         _otherwise ->-           throwChecked $ StackClient.HttpExceptionRequest request-                        $ StackClient.StatusCodeException (void response) ""---- | Wrap custom exceptions------ NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@--- but it is currently disabled <https://github.com/snoyberg/http-client/issues/116>-wrapCustomEx :: (Throws StackClient.HttpException => IO a)-             -> (Throws SomeRemoteError => IO a)-wrapCustomEx act = handleChecked (\(ex :: StackClient.HttpException) -> go ex) act-  where-    go ex = throwChecked (SomeRemoteError ex)--checkHttpException :: Throws StackClient.HttpException => IO a -> IO a-checkHttpException = handle $ \(ex :: StackClient.HttpException) ->-                       throwChecked ex--{--------------------------------------------------------------------------------  http-client auxiliary--------------------------------------------------------------------------------}--hAcceptRanges :: StackClient.HeaderName-hAcceptRanges = "Accept-Ranges"--hAcceptEncoding :: StackClient.HeaderName-hAcceptEncoding = "Accept-Encoding"--setRange :: Int -> Int-         -> StackClient.Request -> StackClient.Request-setRange from to req = req {-      StackClient.requestHeaders = (StackClient.hRange, rangeHeader)-                                : StackClient.requestHeaders req-    }-  where-    -- Content-Range header uses inclusive rather than exclusive bounds-    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>-    rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1)---- | Set request headers-setRequestHeaders :: [HttpRequestHeader]-                  -> StackClient.Request -> StackClient.Request-setRequestHeaders opts req = req {-      StackClient.requestHeaders = trOpt disallowCompressionByDefault opts-    }-  where-    trOpt :: [(StackClient.HeaderName, [ByteString])]-          -> [HttpRequestHeader]-          -> [StackClient.Header]-    trOpt acc [] =-      concatMap finalizeHeader acc-    trOpt acc (HttpRequestMaxAge0:os) =-      trOpt (insert StackClient.hCacheControl ["max-age=0"] acc) os-    trOpt acc (HttpRequestNoTransform:os) =-      trOpt (insert StackClient.hCacheControl ["no-transform"] acc) os--    -- disable content compression (potential security issue)-    disallowCompressionByDefault :: [(StackClient.HeaderName, [ByteString])]-    disallowCompressionByDefault = [(hAcceptEncoding, [])]--    -- Some headers are comma-separated, others need multiple headers for-    -- multiple options.-    ---    -- TODO: Right we we just comma-separate all of them.-    finalizeHeader :: (StackClient.HeaderName, [ByteString])-                   -> [StackClient.Header]-    finalizeHeader (name, strs) = [(name, BS.intercalate ", " (reverse strs))]--    insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]-    insert x y = Lens.modify (Lens.lookupM x) (++ y)---- | Extract the response headers-getResponseHeaders :: StackClient.Response a -> [HttpResponseHeader]-getResponseHeaders response = concat [-      [ HttpResponseAcceptRangesBytes-      | (hAcceptRanges, "bytes") `elem` headers-      ]-    ]-  where-    headers = StackClient.responseHeaders response
− src/Network/HTTP/Download.hs 
@@ -1,121 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-module Network.HTTP.Download-    ( verifiedDownload-    , DownloadRequest(..)-    , drRetryPolicyDefault-    , HashCheck(..)-    , DownloadException(..)-    , CheckHexDigest(..)-    , LengthCheck-    , VerifiedDownloadException(..)--    , download-    , redownload-    , httpJSON-    , httpLbs-    , httpLBS-    , parseRequest-    , parseUrlThrow-    , setGithubHeaders-    , withResponse-    ) where--import           Stack.Prelude-import           Stack.Types.Runner-import qualified Data.ByteString.Lazy        as L-import           Data.Conduit                (yield)-import qualified Data.Conduit.Binary         as CB-import           Data.Text.Encoding.Error    (lenientDecode)-import           Data.Text.Encoding          (decodeUtf8With)-import           Network.HTTP.Download.Verified-import           Network.HTTP.StackClient    (Request, Response, HttpException, httpJSON, httpLbs, httpLBS, withResponse, path, checkResponse, parseUrlThrow, parseRequest, setRequestHeader, getResponseHeaders, requestHeaders, getResponseBody, getResponseStatusCode)-import           Path.IO                     (doesFileExist)-import           System.Directory            (createDirectoryIfMissing,-                                              removeFile)-import           System.FilePath             (takeDirectory, (<.>))---- | Download the given URL to the given location. If the file already exists,--- no download is performed. Otherwise, creates the parent directory, downloads--- to a temporary file, and on file download completion moves to the--- appropriate destination.------ Throws an exception if things go wrong-download :: HasRunner env-         => Request-         -> Path Abs File -- ^ destination-         -> RIO env Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?-download req destpath = do-    let downloadReq = DownloadRequest-            { drRequest = req-            , drHashChecks = []-            , drLengthCheck = Nothing-            , drRetryPolicy = drRetryPolicyDefault-            }-    let progressHook _ = return ()-    verifiedDownload downloadReq destpath progressHook---- | 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 :: HasRunner env-           => Request-           -> Path Abs File -- ^ destination-           -> RIO env Bool-redownload req0 dest = do-    logDebug $ "Downloading " <> display (decodeUtf8With lenientDecode (path req0))-    let destFilePath = toFilePath dest-        etagFilePath = destFilePath <.> "etag"--    metag <- do-      exists <- doesFileExist dest-      if not exists-        then return Nothing-        else liftIO $ handleIO (const $ return Nothing) $ fmap Just $-                 withSourceFile etagFilePath $ \src -> runConduit $ src .| CB.take 512--    let req1 =-            case metag of-                Nothing -> req0-                Just etag -> req0-                    { requestHeaders =-                        requestHeaders req0 ++-                        [("If-None-Match", L.toStrict etag)]-                    }-        req2 = req1 { checkResponse = \_ _ -> return () }-    recoveringHttp drRetryPolicyDefault $ catchingHttpExceptions $ liftIO $-      withResponse req2 $ \res -> case getResponseStatusCode res of-        200 -> 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--          withSinkFileCautious destFilePath $ \sink ->-            runConduit $ getResponseBody res .| sink--          forM_ (lookup "ETag" (getResponseHeaders res)) $ \e ->-            withSinkFileCautious etagFilePath $ \sink ->-            runConduit $ yield e .| sink--          return True-        304 -> return False-        _ -> throwM $ RedownloadInvalidResponse req2 dest $ void res--  where-    catchingHttpExceptions :: RIO env a -> RIO env a-    catchingHttpExceptions action = catch action (throwM . RedownloadHttpError)--data DownloadException = RedownloadInvalidResponse Request (Path Abs File) (Response ())-                       | RedownloadHttpError HttpException-                       -    deriving (Show, Typeable)-instance Exception DownloadException---- | Set the user-agent request header-setGithubHeaders :: Request -> Request-setGithubHeaders = setRequestHeader "Accept" ["application/vnd.github.v3+json"]
− src/Network/HTTP/Download/Verified.hs 
@@ -1,329 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE StandaloneDeriving    #-}-module Network.HTTP.Download.Verified-  ( verifiedDownload-  , recoveringHttp-  , DownloadRequest(..)-  , drRetryPolicyDefault-  , HashCheck(..)-  , CheckHexDigest(..)-  , LengthCheck-  , VerifiedDownloadException(..)-  ) where--import qualified    Data.List as List-import qualified    Data.ByteString as ByteString-import qualified    Data.ByteString.Base64 as B64-import qualified    Data.Conduit.Binary as CB-import qualified    Data.Conduit.List as CL-import qualified    Data.Text as Text-import qualified    Data.Text.Encoding as Text--import              Control.Monad-import              Control.Monad.Catch (Handler (..)) -- would be nice if retry exported this itself-import              Stack.Prelude hiding (Handler (..))-import              Control.Retry (recovering,limitRetries,RetryPolicy,exponentialBackoff,RetryStatus(..))-import              Crypto.Hash-import              Crypto.Hash.Conduit (sinkHash)-import              Data.ByteArray as Mem (convert)-import              Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))-import              Data.ByteString.Char8 (readInteger)-import              Data.Conduit-import              Data.Conduit.Binary (sourceHandle)-import              Data.Text.Encoding (decodeUtf8With)-import              Data.Text.Encoding.Error (lenientDecode)-import              GHC.IO.Exception (IOException(..),IOErrorType(..))-import              Network.HTTP.StackClient (Request, HttpException, httpSink, getUri, path, getResponseHeaders, hContentLength, hContentMD5)-import              Path-import              Stack.Types.Runner-import              Stack.PrettyPrint-import              System.Directory-import qualified    System.FilePath as FP ((<.>))---- | A request together with some checks to perform.-data DownloadRequest = DownloadRequest-    { drRequest :: Request-    , drHashChecks :: [HashCheck]-    , drLengthCheck :: Maybe LengthCheck-    , drRetryPolicy :: RetryPolicy-    }---- | Default to retrying seven times with exponential backoff starting from--- one hundred milliseconds.------ This means the tries will occur after these delays if necessary:------ * 0.1s--- * 0.2s--- * 0.4s--- * 0.8s--- * 1.6s--- * 3.2s--- * 6.4s-drRetryPolicyDefault :: RetryPolicy-drRetryPolicyDefault = limitRetries 7 <> exponentialBackoff onehundredMilliseconds-  where onehundredMilliseconds = 100000--data HashCheck = forall a. (Show a, HashAlgorithm a) => HashCheck-  { hashCheckAlgorithm :: a-  , hashCheckHexDigest :: CheckHexDigest-  }-deriving instance Show HashCheck--data CheckHexDigest-  = CheckHexDigestString String-  | CheckHexDigestByteString ByteString-  | CheckHexDigestHeader ByteString-  deriving Show-instance IsString CheckHexDigest where-  fromString = CheckHexDigestString--type LengthCheck = Int---- | An exception regarding verification of a download.-data VerifiedDownloadException-    = WrongContentLength-          Request-          Int -- expected-          ByteString -- actual (as listed in the header)-    | WrongStreamLength-          Request-          Int -- expected-          Int -- actual-    | WrongDigest-          Request-          String -- algorithm-          CheckHexDigest -- expected-          String -- actual (shown)-  deriving (Typeable)-instance Show VerifiedDownloadException where-    show (WrongContentLength req expected actual) =-        "Download expectation failure: ContentLength header\n"-        ++ "Expected: " ++ show expected ++ "\n"-        ++ "Actual:   " ++ displayByteString actual ++ "\n"-        ++ "For: " ++ show (getUri req)-    show (WrongStreamLength req expected actual) =-        "Download expectation failure: download size\n"-        ++ "Expected: " ++ show expected ++ "\n"-        ++ "Actual:   " ++ show actual ++ "\n"-        ++ "For: " ++ show (getUri req)-    show (WrongDigest req algo expected actual) =-        "Download expectation failure: content hash (" ++ algo ++  ")\n"-        ++ "Expected: " ++ displayCheckHexDigest expected ++ "\n"-        ++ "Actual:   " ++ actual ++ "\n"-        ++ "For: " ++ show (getUri req)--instance Exception VerifiedDownloadException---- This exception is always caught and never thrown outside of this module.-data VerifyFileException-    = WrongFileSize-          Int -- expected-          Integer -- actual (as listed by hFileSize)-  deriving (Show, Typeable)-instance Exception VerifyFileException---- Show a ByteString that is known to be UTF8 encoded.-displayByteString :: ByteString -> String-displayByteString =-    Text.unpack . Text.strip . Text.decodeUtf8---- Show a CheckHexDigest in human-readable format.-displayCheckHexDigest :: CheckHexDigest -> String-displayCheckHexDigest (CheckHexDigestString s) = s ++ " (String)"-displayCheckHexDigest (CheckHexDigestByteString s) = displayByteString s ++ " (ByteString)"-displayCheckHexDigest (CheckHexDigestHeader h) =-      show (B64.decodeLenient h) ++ " (Header. unencoded: " ++ show h ++ ")"----- | Make sure that the hash digest for a finite stream of bytes--- is as expected.------ Throws WrongDigest (VerifiedDownloadException)-sinkCheckHash :: MonadThrow m-    => Request-    -> HashCheck-    -> ConduitM ByteString o m ()-sinkCheckHash req HashCheck{..} = do-    digest <- sinkHashUsing hashCheckAlgorithm-    let actualDigestString = show digest-    let actualDigestHexByteString = Mem.convertToBase Mem.Base16 digest-    let actualDigestBytes = Mem.convert digest--    let passedCheck = case hashCheckHexDigest of-          CheckHexDigestString s -> s == actualDigestString-          CheckHexDigestByteString b -> b == actualDigestHexByteString-          CheckHexDigestHeader b -> B64.decodeLenient b == actualDigestHexByteString-            || B64.decodeLenient b == actualDigestBytes-            -- A hack to allow hackage tarballs to download.-            -- They should really base64-encode their md5 header as per rfc2616#sec14.15.-            -- https://github.com/commercialhaskell/stack/issues/240-            || b == actualDigestHexByteString--    unless passedCheck $-        throwM $ WrongDigest req (show hashCheckAlgorithm) hashCheckHexDigest actualDigestString--assertLengthSink :: MonadThrow m-    => Request-    -> LengthCheck-    -> ZipSink ByteString m ()-assertLengthSink req expectedStreamLength = ZipSink $ do-  Sum actualStreamLength <- CL.foldMap (Sum . ByteString.length)-  when (actualStreamLength /= expectedStreamLength) $-    throwM $ WrongStreamLength req expectedStreamLength actualStreamLength---- | A more explicitly type-guided sinkHash.-sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> ConduitM ByteString o m (Digest a)-sinkHashUsing _ = sinkHash---- | Turns a list of hash checks into a ZipSink that checks all of them.-hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteString m ()-hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req)---- 'Control.Retry.recovering' customized for HTTP failures-recoveringHttp :: forall env a. HasRunner env => RetryPolicy -> RIO env a -> RIO env a-recoveringHttp retryPolicy =-#if MIN_VERSION_retry(0,7,0)-    helper $ \run -> recovering retryPolicy (handlers run) . const-#else-    helper $ \run -> recovering retryPolicy (handlers run)-#endif-  where-    helper :: (UnliftIO (RIO env) -> IO a -> IO a) -> RIO env a -> RIO env a-    helper wrapper action = withUnliftIO $ \run -> wrapper run (unliftIO run action)--    handlers :: UnliftIO (RIO env) -> [RetryStatus -> Handler IO Bool]-    handlers u = [Handler . alwaysRetryHttp u,const $ Handler retrySomeIO]--    alwaysRetryHttp :: UnliftIO (RIO env) -> RetryStatus -> HttpException -> IO Bool-    alwaysRetryHttp u rs _ = do-      unliftIO u $-        prettyWarn $ vcat-          [ flow $ unwords-            [ "Retry number"-            , show (rsIterNumber rs)-            , "after a total delay of"-            , show (rsCumulativeDelay rs)-            , "us"-            ]-          , flow $ unwords-            [ "If you see this warning and stack fails to download,"-            , "but running the command again solves the problem,"-            , "please report here: https://github.com/commercialhaskell/stack/issues/3510"-            , "Make sure to paste the output of 'stack --version'"-            ]-          ]-      return True--    retrySomeIO :: Monad m => IOException -> m Bool-    retrySomeIO e = return $ case ioe_type e of-                               -- hGetBuf: resource vanished (Connection reset by peer)-                               ResourceVanished -> True-                               -- conservatively exclude all others-                               _ -> False---- | Copied and extended version of Network.HTTP.Download.download.------ Has the following additional features:--- * Verifies that response content-length header (if present)---     matches expected length--- * Limits the download to (close to) the expected # of bytes--- * Verifies that the expected # bytes were downloaded (not too few)--- * Verifies md5 if response includes content-md5 header--- * Verifies the expected hashes------ Throws VerifiedDownloadException.--- Throws IOExceptions related to file system operations.--- Throws HttpException.-verifiedDownload-         :: HasRunner env-         => DownloadRequest-         -> Path Abs File -- ^ destination-         -> (Maybe Integer -> ConduitM ByteString Void (RIO env) ()) -- ^ custom hook to observe progress-         -> RIO env Bool -- ^ Whether a download was performed-verifiedDownload DownloadRequest{..} destpath progressSink = do-    let req = drRequest-    whenM' (liftIO getShouldDownload) $ do-        logDebug $ "Downloading " <> Stack.Prelude.display (decodeUtf8With lenientDecode (path req))-        liftIO $ createDirectoryIfMissing True dir-        recoveringHttp drRetryPolicy $-            withSinkFile fptmp $ httpSink req . go-        liftIO $ renameFile fptmp fp-  where-    whenM' mp m = do-        p <- mp-        if p then m >> return True else return False--    fp = toFilePath destpath-    fptmp = fp FP.<.> "tmp"-    dir = toFilePath $ parent destpath--    getShouldDownload = do-        fileExists <- doesFileExist fp-        if fileExists-            -- only download if file does not match expectations-            then not <$> fileMatchesExpectations-            -- or if it doesn't exist yet-            else return True--    -- precondition: file exists-    -- TODO: add logging-    fileMatchesExpectations =-        ((checkExpectations >> return True)-          `catch` \(_ :: VerifyFileException) -> return False)-          `catch` \(_ :: VerifiedDownloadException) -> return False--    checkExpectations = withBinaryFile fp ReadMode $ \h -> do-        for_ drLengthCheck $ checkFileSizeExpectations h-        runConduit-            $ sourceHandle h-           .| getZipSink (hashChecksToZipSink drRequest drHashChecks)--    -- doesn't move the handle-    checkFileSizeExpectations h expectedFileSize = do-        fileSizeInteger <- hFileSize h-        when (fileSizeInteger > toInteger (maxBound :: Int)) $-            throwM $ WrongFileSize expectedFileSize fileSizeInteger-        let fileSize = fromInteger fileSizeInteger-        when (fileSize /= expectedFileSize) $-            throwM $ WrongFileSize expectedFileSize fileSizeInteger--    checkContentLengthHeader headers expectedContentLength =-        case List.lookup hContentLength headers of-            Just lengthBS -> do-              let lengthStr = displayByteString lengthBS-              when (lengthStr /= show expectedContentLength) $-                throwM $ WrongContentLength drRequest expectedContentLength lengthBS-            _ -> return ()--    go sink res = do-        let headers = getResponseHeaders res-            mcontentLength = do-              hLength <- List.lookup hContentLength headers-              (i,_) <- readInteger hLength-              return i-        for_ drLengthCheck $ checkContentLengthHeader headers-        let hashChecks = (case List.lookup hContentMD5 headers of-                Just md5BS ->-                    [ HashCheck-                          { hashCheckAlgorithm = MD5-                          , hashCheckHexDigest = CheckHexDigestHeader md5BS-                          }-                    ]-                Nothing -> []-                ) ++ drHashChecks--        maybe id (\len -> (CB.isolate len .|)) drLengthCheck-            $ getZipSink-                ( hashChecksToZipSink drRequest hashChecks-                  *> maybe (pure ()) (assertLengthSink drRequest) drLengthCheck-                  *> ZipSink sink-                  *> ZipSink (progressSink mcontentLength))
src/Network/HTTP/StackClient.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}  -- |@@ -7,27 +8,17 @@ module Network.HTTP.StackClient   ( httpJSON   , httpLbs-  , httpLBS   , httpNoBody   , httpSink-  , setUserAgent   , withResponse-  , withResponseByManager   , setRequestMethod   , setRequestHeader   , addRequestHeader   , setRequestBody-  , setRequestManager   , getResponseHeaders   , getResponseBody   , getResponseStatusCode-  , Network.HTTP.Client.responseHeaders-  , Network.HTTP.Client.responseStatus-  , Network.HTTP.Client.responseBody   , parseRequest-  , parseRequest_-  , defaultRequest-  , setUri   , getUri   , path   , checkResponse@@ -39,45 +30,42 @@   , Request   , RequestBody(RequestBodyBS, RequestBodyLBS)   , Response-  , Manager-  , Header-  , HeaderName-  , HttpException(HttpExceptionRequest)-  , HttpExceptionContent(StatusCodeException)+  , HttpException   , hAccept   , hContentLength   , hContentMD5-  , hCacheControl-  , hRange   , methodPut-  , ok200-  , partialContent206-  , Proxy-  , useProxy-  , noProxy-  , proxyEnvironment-  , managerSetProxy   , formDataBody   , partFileRequestBody   , partBS   , partLBS+  , setGithubHeaders+  , download+  , redownload+  , verifiedDownload+  , CheckHexDigest (..)+  , DownloadRequest (..)+  , drRetryPolicyDefault+  , DownloadException (..)+  , HashCheck (..)   ) where  import           Data.Aeson (FromJSON) import qualified Data.ByteString as Strict-import           Data.ByteString.Lazy (ByteString)-import           Data.Conduit (ConduitM, transPipe)+import           Data.Conduit (ConduitM) import           Data.Void (Void)-import qualified Network.HTTP.Client-import           Network.HTTP.Client (BodyReader, Manager, Request, RequestBody(..), Response, Manager, HttpExceptionContent(..), parseRequest, parseRequest_, defaultRequest, getUri, path, checkResponse, parseUrlThrow, responseStatus, responseBody, useProxy, noProxy, proxyEnvironment, managerSetProxy, Proxy)-import           Network.HTTP.Client.Internal (setUri)-import           Network.HTTP.Simple (setRequestMethod, setRequestBody, setRequestHeader, addRequestHeader, setRequestManager, HttpException(..), getResponseBody, getResponseStatusCode, getResponseHeaders)-import           Network.HTTP.Types (hAccept, hContentLength, hContentMD5, hCacheControl, hRange, methodPut, Header, HeaderName, ok200, partialContent206)+import           Network.HTTP.Client (Request, RequestBody(..), Response, parseRequest, getUri, path, checkResponse, parseUrlThrow)+import           Network.HTTP.Simple (setRequestMethod, setRequestBody, setRequestHeader, addRequestHeader, HttpException(..), getResponseBody, getResponseStatusCode, getResponseHeaders)+import           Network.HTTP.Types (hAccept, hContentLength, hContentMD5, methodPut) import           Network.HTTP.Conduit (requestHeaders) import           Network.HTTP.Client.TLS (getGlobalManager, applyDigestAuth, displayDigestAuthException)+import           Network.HTTP.Download hiding (download, redownload, verifiedDownload)+import qualified Network.HTTP.Download as Download import qualified Network.HTTP.Simple import           Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody, partBS, partLBS)-import           UnliftIO (MonadIO, MonadUnliftIO, withRunInIO, withUnliftIO, unliftIO)+import           Path+import           RIO+import           RIO.PrettyPrint   setUserAgent :: Request -> Request@@ -88,14 +76,10 @@ httpJSON = Network.HTTP.Simple.httpJSON . setUserAgent  -httpLbs :: MonadIO m => Request -> m (Response ByteString)+httpLbs :: MonadIO m => Request -> m (Response LByteString) httpLbs = Network.HTTP.Simple.httpLbs . setUserAgent  -httpLBS :: MonadIO m => Request -> m (Response ByteString)-httpLBS = httpLbs-- httpNoBody :: MonadIO m => Request -> m (Response ()) httpNoBody = Network.HTTP.Simple.httpNoBody . setUserAgent @@ -105,17 +89,59 @@   => Request   -> (Response () -> ConduitM Strict.ByteString Void m a)   -> m a-httpSink req inner = withUnliftIO $ \u ->-  Network.HTTP.Simple.httpSink (setUserAgent req) (transPipe (unliftIO u) . inner)+httpSink = Network.HTTP.Simple.httpSink . setUserAgent   withResponse   :: (MonadUnliftIO m, MonadIO n)   => Request -> (Response (ConduitM i Strict.ByteString n ()) -> m a) -> m a-withResponse req inner = withRunInIO $ \run ->-  Network.HTTP.Simple.withResponse (setUserAgent req) (run . inner)+withResponse = Network.HTTP.Simple.withResponse . setUserAgent +-- | Set the user-agent request header+setGithubHeaders :: Request -> Request+setGithubHeaders = setRequestHeader "Accept" ["application/vnd.github.v3+json"] -withResponseByManager :: MonadUnliftIO m => Request -> Manager -> (Response BodyReader -> m a) -> m a-withResponseByManager req man inner = withRunInIO $ \run ->-  Network.HTTP.Client.withResponse (setUserAgent req) man (run . inner)+-- | Download the given URL to the given location. If the file already exists,+-- no download is performed. Otherwise, creates the parent directory, downloads+-- to a temporary file, and on file download completion moves to the+-- appropriate destination.+--+-- Throws an exception if things go wrong+download :: HasTerm env+         => Request+         -> Path Abs File -- ^ destination+         -> RIO env Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?+download req dest = Download.download (setUserAgent req) dest++-- | 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 :: HasTerm env+           => Request+           -> Path Abs File -- ^ destination+           -> RIO env Bool+redownload req dest = Download.redownload (setUserAgent req) dest++-- | Copied and extended version of Network.HTTP.Download.download.+--+-- Has the following additional features:+-- * Verifies that response content-length header (if present)+--     matches expected length+-- * Limits the download to (close to) the expected # of bytes+-- * Verifies that the expected # bytes were downloaded (not too few)+-- * Verifies md5 if response includes content-md5 header+-- * Verifies the expected hashes+--+-- Throws VerifiedDownloadException.+-- Throws IOExceptions related to file system operations.+-- Throws HttpException.+verifiedDownload+         :: HasTerm env+         => DownloadRequest+         -> Path Abs File -- ^ destination+         -> (Maybe Integer -> ConduitM ByteString Void (RIO env) ()) -- ^ custom hook to observe progress+         -> RIO env Bool -- ^ Whether a download was performed+verifiedDownload dr destpath progressSink =+    Download.verifiedDownload dr' destpath progressSink+  where+    dr' = dr {drRequest = setUserAgent (drRequest dr)}
src/Options/Applicative/Builder/Extra.hs view
@@ -7,8 +7,9 @@ module Options.Applicative.Builder.Extra   (boolFlags   ,boolFlagsNoDefault-  ,maybeBoolFlags-  ,firstBoolFlags+  ,firstBoolFlagsNoDefault+  ,firstBoolFlagsTrue+  ,firstBoolFlagsFalse   ,enableDisableFlags   ,enableDisableFlagsNoDefault   ,extraHelpOption@@ -16,6 +17,8 @@   ,textOption   ,textArgument   ,optionalFirst+  ,optionalFirstTrue+  ,optionalFirstFalse   ,absFileOption   ,relFileOption   ,absDirOption@@ -48,7 +51,13 @@           -> String               -- ^ Help suffix           -> Mod FlagFields Bool           -> Parser Bool-boolFlags defaultValue = enableDisableFlags defaultValue True False+boolFlags defaultValue name helpSuffix =+  enableDisableFlags defaultValue True False name $ concat+    [ helpSuffix+    , " (default: "+    , if defaultValue then "enabled" else "disabled"+    , ")"+    ]  -- | Enable/disable flags for a 'Bool', without a default case (to allow chaining with '<|>'). boolFlagsNoDefault :: String               -- ^ Flag name@@ -57,17 +66,25 @@                    -> Parser Bool boolFlagsNoDefault = enableDisableFlagsNoDefault True False --- | Enable/disable flags for a @('Maybe' 'Bool')@.-maybeBoolFlags :: String                       -- ^ Flag name-               -> String                       -- ^ Help suffix-               -> Mod FlagFields (Maybe Bool)-               -> Parser (Maybe Bool)-maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False)+-- | Flag with no default of True or False+firstBoolFlagsNoDefault :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (First Bool)+firstBoolFlagsNoDefault name helpSuffix mod' =+  First <$>+  enableDisableFlags Nothing (Just True) (Just False)+  name helpSuffix mod' --- | Like 'maybeBoolFlags', but parsing a 'First'.-firstBoolFlags :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (First Bool)-firstBoolFlags long0 help0 mod0 = First <$> maybeBoolFlags long0 help0 mod0+-- | Flag with a Semigroup instance and a default of True+firstBoolFlagsTrue :: String -> String -> Mod FlagFields FirstTrue -> Parser FirstTrue+firstBoolFlagsTrue name helpSuffix =+  enableDisableFlags mempty (FirstTrue (Just True)) (FirstTrue (Just False))+  name $ helpSuffix ++ " (default: enabled)" +-- | Flag with a Semigroup instance and a default of False+firstBoolFlagsFalse :: String -> String -> Mod FlagFields FirstFalse -> Parser FirstFalse+firstBoolFlagsFalse name helpSuffix =+  enableDisableFlags mempty (FirstFalse (Just True)) (FirstFalse (Just False))+  name $ helpSuffix ++ " (default: disabled)"+ -- | Enable/disable flags for any type. enableDisableFlags :: a                 -- ^ Default value                    -> a                 -- ^ Enabled value@@ -160,6 +177,14 @@ -- | Like 'optional', but returning a 'First'. optionalFirst :: Alternative f => f a -> f (First a) optionalFirst = fmap First . optional++-- | Like 'optional', but returning a 'FirstTrue'.+optionalFirstTrue :: Alternative f => f Bool -> f FirstTrue+optionalFirstTrue = fmap FirstTrue . optional++-- | Like 'optional', but returning a 'FirstFalse'.+optionalFirstFalse :: Alternative f => f Bool -> f FirstFalse+optionalFirstFalse = fmap FirstFalse . optional  absFileOption :: Mod OptionFields (Path Abs File) -> Parser (Path Abs File) absFileOption mods = option (eitherReader' parseAbsFile) $
src/Options/Applicative/Complicated.hs view
@@ -15,7 +15,6 @@  import           Control.Monad.Trans.Except import           Control.Monad.Trans.Writer-import           Data.Version import           Options.Applicative import           Options.Applicative.Types import           Options.Applicative.Builder.Internal@@ -45,7 +44,7 @@   -> ExceptT b (Writer (Mod CommandFields (b,a))) ()   -- ^ commands (use 'addCommand')   -> IO (a,b)-complicatedOptions numericVersion versionString numericHpackVersion h pd footerStr commonParser mOnFailure commandParser =+complicatedOptions numericVersion stringVersion numericHpackVersion h pd footerStr commonParser mOnFailure commandParser =   do args <- getArgs      (a,(b,c)) <- case execParserPure (prefs noBacktrack) parser args of        Failure _ | null args -> withArgs ["--help"] (execParser parser)@@ -56,8 +55,8 @@   where parser = info (helpOption <*> versionOptions <*> complicatedParser "COMMAND|FILE" commonParser commandParser) desc         desc = fullDesc <> header h <> progDesc pd <> footer footerStr         versionOptions =-          case versionString of-            Nothing -> versionOption (showVersion numericVersion)+          case stringVersion of+            Nothing -> versionOption (versionString numericVersion)             Just s -> versionOption s <*> numericVersionOption <*> numericHpackVersionOption         versionOption s =           infoOption@@ -66,7 +65,7 @@              help "Show version")         numericVersionOption =           infoOption-            (showVersion numericVersion)+            (versionString numericVersion)             (long "numeric-version" <>              help "Show only version number")         numericHpackVersionOption =@@ -80,11 +79,12 @@            -> String   -- ^ title of command            -> String   -- ^ footer of command help            -> (a -> b) -- ^ constructor to wrap up command in common data type+           -> (a -> c -> c) -- ^ extend common settings from local settings            -> Parser c -- ^ common parser            -> Parser a -- ^ command parser            -> ExceptT b (Writer (Mod CommandFields (b,c))) ()-addCommand cmd title footerStr constr =-  addCommand' cmd title footerStr (\a c -> (constr a,c))+addCommand cmd title footerStr constr extendCommon =+  addCommand' cmd title footerStr (\a c -> (constr a,extendCommon a c))  -- | Add a command that takes sub-commands to the options dispatcher. addSubCommands
src/Path/CheckInstall.hs view
@@ -7,7 +7,7 @@ import           Control.Monad.Extra (anyM, (&&^)) import qualified Data.Text as T import           Stack.Prelude-import           Stack.PrettyPrint+import           RIO.PrettyPrint import           Stack.Types.Config import qualified System.Directory as D import qualified System.FilePath as FP@@ -29,25 +29,25 @@                     unless (exeDir `FP.equalFilePath` destDir) $ do                         prettyWarnL                           [ flow "The"-                          , styleFile . fromString . T.unpack $ exe+                          , style File . fromString . T.unpack $ exe                           , flow "executable found on the PATH environment variable is"-                          , styleFile . fromString $ exePath+                          , style File . fromString $ exePath                           , flow "and not the version that was just installed."                           , flow "This means that"-                          , styleFile . fromString . T.unpack $ exe+                          , style File . fromString . T.unpack $ exe                           , "calls on the command line will not use this version."                           ]                 Nothing -> do                     prettyWarnL                       [ flow "Installation path"-                      , styleDir . fromString $ destDir+                      , style Dir . fromString $ destDir                       , flow "is on the PATH but the"-                      , styleFile . fromString . T.unpack $ exe+                      , style File . fromString . T.unpack $ exe                       , flow "executable that was just installed could not be found on the PATH."                       ]         else do             prettyWarnL               [ flow "Installation path "-              , styleDir . fromString $ destDir+              , style Dir . fromString $ destDir               , "not found on the PATH environment variable."               ]
src/Path/Find.hs view
@@ -10,7 +10,7 @@   ,findInParents)   where -import Stack.Prelude+import RIO import System.IO.Error (isPermissionError) import Data.List import Path
src/Stack/Build.hs view
@@ -1,14 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}  -- | Build the project. @@ -21,7 +16,7 @@   ,CabalVersionException(..))   where -import           Stack.Prelude+import           Stack.Prelude hiding (loadPackage) import           Data.Aeson (Value (Object, Array), (.=), object) import qualified Data.HashMap.Strict as HM import           Data.List ((\\), isPrefixOf)@@ -36,34 +31,21 @@ import           Data.Text.Read (decimal) import qualified Data.Vector as V import qualified Data.Yaml as Yaml+import           Distribution.Version (mkVersion)+import           Path (parent) import           Stack.Build.ConstructPlan import           Stack.Build.Execute-import           Stack.Build.Haddock import           Stack.Build.Installed import           Stack.Build.Source-import           Stack.Build.Target import           Stack.Package-import           Stack.PackageLocation (parseSingleCabalFileIndex) import           Stack.Types.Build-import           Stack.Types.BuildPlan import           Stack.Types.Config-import           Stack.Types.FlagName import           Stack.Types.NamedComponent import           Stack.Types.Package-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Version--import           Stack.Types.Compiler (compilerVersionText-#ifdef WINDOWS-                                      ,getGhcVersion-#endif-                                      )-import           System.FileLock (FileLock, unlockFile)+import           Stack.Types.SourceMap -#ifdef WINDOWS-import           System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP)-#endif+import           Stack.Types.Compiler (compilerVersionText, getGhcVersion)+import           System.Terminal (fixCodePage)  -- | Build. --@@ -71,56 +53,40 @@ --   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 :: HasEnvConfig env-      => (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files-      -> Maybe FileLock-      -> BuildOptsCLI+      => Maybe (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files       -> RIO env ()-build setLocalFiles mbuildLk boptsCli = fixCodePage $ do+build msetLocalFiles = do+  mcp <- view $ configL.to configModifyCodePage+  ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion+  fixCodePage mcp ghcVersion $ do     bopts <- view buildOptsL-    let profiling = boptsLibProfile bopts || boptsExeProfile bopts-    let symbols = not (boptsLibStrip bopts || boptsExeStrip bopts)--    (targets, ls, locals, extraToBuild, sourceMap) <- loadSourceMapFull NeedTargets boptsCli+    sourceMap <- view $ envConfigL.to envConfigSourceMap+    locals <- projectLocalPackages+    depsLocals <- localDependencies+    let allLocals = locals <> depsLocals      -- Set local files, necessary for file watching     stackYaml <- view stackYamlL-    liftIO $ setLocalFiles-           $ Set.insert stackYaml-           $ Set.unions-             -- The `locals` value above only contains local project-             -- packages, not local dependencies. This will get _all_-             -- of the local files we're interested in-             -- watching. Arguably, we should not bother watching repo-             -- and archive files, since those shouldn't-             -- change. That's a possible optimization to consider.-             [lpFiles lp | PSFiles lp _ <- Map.elems sourceMap]+    for_ msetLocalFiles $ \setLocalFiles -> do+      files <- sequence+        [lpFiles lp | lp <- allLocals]+      liftIO $ setLocalFiles $ Set.insert stackYaml $ Set.unions files +    checkComponentsBuildable allLocals++    installMap <- toInstallMap sourceMap     (installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <--        getInstalled-                     GetInstalledOpts-                         { getInstalledProfiling = profiling-                         , getInstalledHaddock   = shouldHaddockDeps bopts-                         , getInstalledSymbols   = symbols }-                     sourceMap+        getInstalled installMap +    boptsCli <- view $ envConfigL.to envConfigBuildOptsCLI     baseConfigOpts <- mkBaseConfigOpts boptsCli-    plan <- constructPlan ls baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli)+    plan <- constructPlan baseConfigOpts localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli)      allowLocals <- view $ configL.to configAllowLocals     unless allowLocals $ case justLocals plan of       [] -> return ()       localsIdents -> throwM $ LocalPackagesPresent localsIdents -    -- If our work to do is all local, let someone else have a turn with the snapshot.-    -- They won't damage what's already in there.-    case (mbuildLk, allLocal plan) of-       -- NOTE: This policy is too conservative.  In the future we should be able to-       -- schedule unlocking as an Action that happens after all non-local actions are-       -- complete.-      (Just lk,True) -> do logDebug "All installs are local; releasing snapshot lock early."-                           liftIO $ unlockFile lk-      _ -> return ()-     checkCabalVersion     warnAboutSplitObjs bopts     warnIfExecutablesWithSameNameCouldBeOverwritten locals plan@@ -135,17 +101,9 @@                          snapshotDumpPkgs                          localDumpPkgs                          installedMap-                         targets+                         (smtTargets $ smTargets sourceMap)                          plan --- | If all the tasks are local, they don't mutate anything outside of our local directory.-allLocal :: Plan -> Bool-allLocal =-    all (== Local) .-    map taskLocation .-    Map.elems .-    planTasks- justLocals :: Plan -> [PackageIdentifier] justLocals =     map taskProvides .@@ -158,11 +116,20 @@     allowNewer <- view $ configL.to configAllowNewer     cabalVer <- view cabalVersionL     -- https://github.com/haskell/cabal/issues/2023-    when (allowNewer && cabalVer < $(mkVersion "1.22")) $ throwM $+    when (allowNewer && cabalVer < mkVersion [1, 22]) $ throwM $         CabalVersionException $             "Error: --allow-newer requires at least Cabal version 1.22, but version " ++             versionString cabalVer ++             " was found."+    -- Since --exact-configuration is always passed, some old cabal+    -- versions can no longer be used. See the following link for why+    -- it's 1.19.2:+    -- https://github.com/haskell/cabal/blob/580fe6b6bf4e1648b2f66c1cb9da9f1f1378492c/cabal-install/Distribution/Client/Setup.hs#L592+    when (cabalVer < mkVersion [1, 19, 2]) $ throwM $+        CabalVersionException $+            "Stack no longer supports Cabal versions older than 1.19.2, but version " +++            versionString cabalVer +++            " was found.  To fix this, consider updating the resolver to lts-3.0 or later / nightly-2015-05-05 or later."  newtype CabalVersionException = CabalVersionException { unCabalVersionException :: String }     deriving (Typeable)@@ -182,7 +149,7 @@             exesText pkgs =                 T.intercalate                     ", "-                    ["'" <> packageNameText p <> ":" <> exe <> "'" | p <- pkgs]+                    ["'" <> T.pack (packageNameString p) <> ":" <> exe <> "'" | p <- pkgs]         (logWarn . display . T.unlines . concat)             [ [ "Building " <> exe_s <> " " <> exesText toBuild <> "." ]             , [ "Only one of them will be available via 'stack exec' or locally installed."@@ -224,9 +191,9 @@     exesToBuild :: Map Text (NonEmpty PackageName)     exesToBuild =         collect-            [ (exe,pkgName)-            | (pkgName,task) <- Map.toList (planTasks plan)-            , TTFiles lp _ <- [taskType task] -- FIXME analyze logic here, do we need to check for Local?+            [ (exe,pkgName')+            | (pkgName',task) <- Map.toList (planTasks plan)+            , TTLocalMutable lp <- [taskType task]             , exe <- (Set.toList . exeComponents . lpComponents) lp             ]     localExes :: Map Text (NonEmpty PackageName)@@ -253,8 +220,8 @@      ]  -- | Get the @BaseConfigOpts@ necessary for constructing configure options-mkBaseConfigOpts :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)-                 => BuildOptsCLI -> m BaseConfigOpts+mkBaseConfigOpts :: (HasEnvConfig env)+                 => BuildOptsCLI -> RIO env BaseConfigOpts mkBaseConfigOpts boptsCli = do     bopts <- view buildOptsL     snapDBPath <- packageDatabaseDeps@@ -274,71 +241,25 @@  -- | Provide a function for loading package information from the package index loadPackage-  :: HasEnvConfig env-  => PackageLocationIndex FilePath+  :: (HasBuildConfig env, HasSourceMap env)+  => PackageLocationImmutable   -> Map FlagName Bool-  -> [Text]+  -> [Text] -- ^ GHC options+  -> [Text] -- ^ Cabal configure options   -> RIO env Package-loadPackage loc flags ghcOptions = do+loadPackage loc flags ghcOptions cabalConfigOpts = do   compiler <- view actualCompilerVersionL   platform <- view platformL-  root <- view projectRootL   let pkgConfig = PackageConfig         { packageConfigEnableTests = False         , packageConfigEnableBenchmarks = False         , packageConfigFlags = flags         , packageConfigGhcOptions = ghcOptions+        , packageConfigCabalConfigOpts = cabalConfigOpts         , packageConfigCompilerVersion = compiler         , packageConfigPlatform = platform         }-  resolvePackage pkgConfig <$> parseSingleCabalFileIndex root loc---- | Set the code page for this process as necessary. Only applies to Windows.--- See: https://github.com/commercialhaskell/stack/issues/738-fixCodePage :: HasEnvConfig env => RIO env a -> RIO env a-#ifdef WINDOWS-fixCodePage inner = do-    mcp <- view $ configL.to configModifyCodePage-    ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion-    if mcp && ghcVersion < $(mkVersion "7.10.3")-        then fixCodePage'-        -- GHC >=7.10.3 doesn't need this code page hack.-        else inner-  where-    fixCodePage' = do-        origCPI <- liftIO getConsoleCP-        origCPO <- liftIO getConsoleOutputCP--        let setInput = origCPI /= expected-            setOutput = origCPO /= expected-            fixInput-                | setInput = bracket_-                    (liftIO $ do-                        setConsoleCP expected)-                    (liftIO $ setConsoleCP origCPI)-                | otherwise = id-            fixOutput-                | setOutput = bracket_-                    (liftIO $ do-                        setConsoleOutputCP expected)-                    (liftIO $ setConsoleOutputCP origCPO)-                | otherwise = id--        case (setInput, setOutput) of-            (False, False) -> return ()-            (True, True) -> warn ""-            (True, False) -> warn " input"-            (False, True) -> warn " output"--        fixInput $ fixOutput inner-    expected = 65001 -- UTF-8-    warn typ = logInfo $-        "Setting" <>-        typ <>-        " codepage to UTF-8 (65001) to ensure correct output from GHC"-#else-fixCodePage = id-#endif+  resolvePackage pkgConfig <$> loadCabalFileImmutable loc  -- | Query information about the build and print the result to stdout in YAML format. queryBuildInfo :: HasEnvConfig env@@ -384,17 +305,15 @@ -- | Get the raw build information object rawBuildInfo :: HasEnvConfig env => RIO env Value rawBuildInfo = do-    (locals, _sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI-    wantedCompiler <- view $ wantedCompilerVersionL.to compilerVersionText+    locals <- projectLocalPackages+    wantedCompiler <- view $ wantedCompilerVersionL.to (utf8BuilderToText . display)     actualCompiler <- view $ actualCompilerVersionL.to compilerVersionText-    globalHints <- view globalHintsL     return $ object         [ "locals" .= Object (HM.fromList $ map localToPair locals)         , "compiler" .= object             [ "wanted" .= wantedCompiler             , "actual" .= actualCompiler             ]-        , "global-hints" .= globalHints         ]   where     localToPair lp =@@ -402,6 +321,16 @@       where         p = lpPackage lp         value = object-            [ "version" .= packageVersion p-            , "path" .= toFilePath (lpDir lp)+            [ "version" .= CabalString (packageVersion p)+            , "path" .= toFilePath (parent $ lpCabalFile lp)             ]++checkComponentsBuildable :: MonadThrow m => [LocalPackage] -> m ()+checkComponentsBuildable lps =+    unless (null unbuildable) $ throwM $ SomeTargetsNotBuildable unbuildable+  where+    unbuildable =+        [ (packageName (lpPackage lp), c)+        | lp <- lps+        , c <- Set.toList (lpUnbuildable lp)+        ]
src/Stack/Build/Cache.hs view
@@ -1,15 +1,11 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TupleSections         #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE FlexibleContexts      #-}-{-# OPTIONS_GHC -fno-warn-orphans  #-}+ -- | Cache information about previous builds module Stack.Build.Cache     ( tryGetBuildCache@@ -35,43 +31,34 @@  import           Stack.Prelude import           Crypto.Hash (hashWith, SHA256(..))-import           Control.Monad.Trans.Maybe import qualified Data.ByteArray as Mem (convert)-import qualified Data.ByteString.Base64.URL as B64URL-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as S8-#ifdef mingw32_HOST_OS-import           Data.Char (ord)-#endif import qualified Data.Map as M import qualified Data.Set as Set-import qualified Data.Store as Store-import           Data.Store.VersionTagged import qualified Data.Text as T-import qualified Data.Text.Encoding as TE+import qualified Data.Yaml as Yaml+import           Foreign.C.Types (CTime) import           Path import           Path.IO+import           Stack.Constants import           Stack.Constants.Config+import           Stack.Storage import           Stack.Types.Build-import           Stack.Types.BuildPlan-import           Stack.Types.Compiler+import           Stack.Types.Cache import           Stack.Types.Config import           Stack.Types.GhcPkgId import           Stack.Types.NamedComponent-import           Stack.Types.Package-import           Stack.Types.PackageIdentifier-import           Stack.Types.Version-import qualified System.FilePath as FP+import           Stack.Types.SourceMap (smRelDir)+import           System.PosixCompat.Files (modificationTime, getFileStatus, setFileTimes)  -- | Directory containing files to mark an executable as installed-exeInstalledDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m)-                => InstallLocation -> m (Path Abs Dir)-exeInstalledDir Snap = (</> $(mkRelDir "installed-packages")) `liftM` installationRootDeps-exeInstalledDir Local = (</> $(mkRelDir "installed-packages")) `liftM` installationRootLocal+exeInstalledDir :: (HasEnvConfig env)+                => InstallLocation -> RIO env (Path Abs Dir)+exeInstalledDir Snap = (</> relDirInstalledPackages) `liftM` installationRootDeps+exeInstalledDir Local = (</> relDirInstalledPackages) `liftM` installationRootLocal  -- | Get all of the installed executables-getInstalledExes :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)-                 => InstallLocation -> m [PackageIdentifier]+getInstalledExes :: (HasEnvConfig env)+                 => InstallLocation -> RIO env [PackageIdentifier] getInstalledExes loc = do     dir <- exeInstalledDir loc     (_, files) <- liftIO $ handleIO (const $ return ([], [])) $ listDir dir@@ -82,30 +69,30 @@         -- before https://github.com/commercialhaskell/stack/issues/2373         -- was fixed), then we don't know which is correct - ignore them.         M.fromListWith (\_ _ -> []) $-        map (\x -> (packageIdentifierName x, [x])) $-        mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files+        map (\x -> (pkgName x, [x])) $+        mapMaybe (parsePackageIdentifier . toFilePath . filename) files  -- | Mark the given executable as installed-markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)-                 => InstallLocation -> PackageIdentifier -> m ()+markExeInstalled :: (HasEnvConfig env)+                 => InstallLocation -> PackageIdentifier -> RIO env () markExeInstalled loc ident = do     dir <- exeInstalledDir loc     ensureDir dir     ident' <- parseRelFile $ packageIdentifierString ident-    let fp = toFilePath $ dir </> ident'+    let fp = dir </> ident'     -- Remove old install records for this package.     -- TODO: This is a bit in-efficient. Put all this metadata into one file?     installed <- getInstalledExes loc-    forM_ (filter (\x -> packageIdentifierName ident == packageIdentifierName x) installed)+    forM_ (filter (\x -> pkgName ident == pkgName x) installed)           (markExeNotInstalled loc)     -- TODO consideration for the future: list all of the executables     -- installed, and invalidate this file in getInstalledExes if they no     -- longer exist-    liftIO $ B.writeFile fp "Installed"+    writeBinaryFileAtomic fp "Installed"  -- | Mark the given executable as not installed-markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)-                    => InstallLocation -> PackageIdentifier -> m ()+markExeNotInstalled :: (HasEnvConfig env)+                    => InstallLocation -> PackageIdentifier -> RIO env () markExeNotInstalled loc ident = do     dir <- exeInstalledDir loc     ident' <- parseRelFile $ packageIdentifierString ident@@ -117,6 +104,8 @@                -> m (Path Abs File) buildCacheFile dir component = do     cachesDir <- buildCachesDir dir+    smh <- view $ envConfigL.to envConfigSourceMapHash+    smDirName <- smRelDir smh     let nonLibComponent prefix name = prefix <> "-" <> T.unpack name     cacheFileName <- parseRelFile $ case component of         CLib -> "lib"@@ -124,24 +113,32 @@         CExe name -> nonLibComponent "exe" name         CTest name -> nonLibComponent "test" name         CBench name -> nonLibComponent "bench" name-    return $ cachesDir </> cacheFileName+    return $ cachesDir </> smDirName </> cacheFileName  -- | Try to read the dirtiness cache for the given package directory. tryGetBuildCache :: HasEnvConfig env                  => Path Abs Dir                  -> NamedComponent                  -> RIO env (Maybe (Map FilePath FileCacheInfo))-tryGetBuildCache dir component = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir component+tryGetBuildCache dir component = do+  fp <- buildCacheFile dir component+  ensureDir $ parent fp+  either (const Nothing) (Just . buildCacheTimes) <$>+    liftIO (tryAny (Yaml.decodeFileThrow (toFilePath fp)))  -- | Try to read the dirtiness cache for the given package directory. tryGetConfigCache :: HasEnvConfig env                   => Path Abs Dir -> RIO env (Maybe ConfigCache)-tryGetConfigCache dir = $(versionedDecodeFile configCacheVC) =<< configCacheFile dir+tryGetConfigCache dir =+    loadConfigCache $ configCacheKey dir ConfigCacheTypeConfig  -- | Try to read the mod time of the cabal file from the last build tryGetCabalMod :: HasEnvConfig env-               => Path Abs Dir -> RIO env (Maybe ModTime)-tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir+               => Path Abs Dir -> RIO env (Maybe CTime)+tryGetCabalMod dir = do+  fp <- toFilePath <$> configCabalMod dir+  liftIO $ either (const Nothing) (Just . modificationTime) <$>+      tryIO (getFileStatus fp)  -- | Write the dirtiness cache for this package's files. writeBuildCache :: HasEnvConfig env@@ -149,8 +146,8 @@                 -> NamedComponent                 -> Map FilePath FileCacheInfo -> RIO env () writeBuildCache dir component times = do-    fp <- buildCacheFile dir component-    $(versionedEncodeFile buildCacheVC) fp BuildCache+    fp <- toFilePath <$> buildCacheFile dir component+    liftIO $ Yaml.encodeFile fp BuildCache         { buildCacheTimes = times         } @@ -159,65 +156,68 @@                 => Path Abs Dir                 -> ConfigCache                 -> RIO env ()-writeConfigCache dir x = do-    fp <- configCacheFile dir-    $(versionedEncodeFile configCacheVC) fp x+writeConfigCache dir =+    saveConfigCache (configCacheKey dir ConfigCacheTypeConfig)  -- | See 'tryGetCabalMod' writeCabalMod :: HasEnvConfig env               => Path Abs Dir-              -> ModTime+              -> CTime               -> RIO env () writeCabalMod dir x = do     fp <- configCabalMod dir-    $(versionedEncodeFile modTimeVC) fp x+    writeBinaryFileAtomic fp "Just used for its modification time"+    liftIO $ setFileTimes (toFilePath fp) x x  -- | Delete the caches for the project.-deleteCaches :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)-             => Path Abs Dir -> m ()-deleteCaches dir = do+deleteCaches :: HasEnvConfig env => Path Abs Dir -> RIO env ()+deleteCaches dir     {- FIXME confirm that this is acceptable to remove     bfp <- buildCacheFile dir     removeFileIfExists bfp     -}-    cfp <- configCacheFile dir-    liftIO $ ignoringAbsence (removeFile cfp)+ = deactiveConfigCache $ configCacheKey dir ConfigCacheTypeConfig -flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)-              => Installed-              -> m (Path Abs File)-flagCacheFile installed = do-    rel <- parseRelFile $-        case installed of-            Library _ gid _ -> ghcPkgIdString gid-            Executable ident -> packageIdentifierString ident-    dir <- flagCacheLocal-    return $ dir </> rel+flagCacheKey :: (HasEnvConfig env) => Installed -> RIO env ConfigCacheKey+flagCacheKey installed = do+    installationRoot <- installationRootLocal+    case installed of+        Library _ gid _ ->+            return $+            configCacheKey installationRoot (ConfigCacheTypeFlagLibrary gid)+        Executable ident ->+            return $+            configCacheKey+                installationRoot+                (ConfigCacheTypeFlagExecutable ident)  -- | Loads the flag cache for the given installed extra-deps tryGetFlagCache :: HasEnvConfig env                 => Installed                 -> RIO env (Maybe ConfigCache) tryGetFlagCache gid = do-    fp <- flagCacheFile gid-    $(versionedDecodeFile configCacheVC) fp+    key <- flagCacheKey gid+    loadConfigCache key  writeFlagCache :: HasEnvConfig env                => Installed                -> ConfigCache                -> RIO env () writeFlagCache gid cache = do-    file <- flagCacheFile gid-    ensureDir (parent file)-    $(versionedEncodeFile configCacheVC) file cache+    key <- flagCacheKey gid+    saveConfigCache key cache +successBS, failureBS :: IsString s => s+successBS = "success"+failureBS = "failure"+ -- | Mark a test suite as having succeeded setTestSuccess :: HasEnvConfig env                => Path Abs Dir                -> RIO env () setTestSuccess dir = do     fp <- testSuccessFile dir-    $(versionedEncodeFile testSuccessVC) fp True+    writeBinaryFileAtomic fp successBS  -- | Mark a test suite as not having succeeded unsetTestSuccess :: HasEnvConfig env@@ -225,16 +225,18 @@                  -> RIO env () unsetTestSuccess dir = do     fp <- testSuccessFile dir-    $(versionedEncodeFile testSuccessVC) fp False+    writeBinaryFileAtomic fp failureBS  -- | Check if the test suite already passed checkTestSuccess :: HasEnvConfig env                  => Path Abs Dir                  -> RIO env Bool-checkTestSuccess dir =-    liftM-        (fromMaybe False)-        ($(versionedDecodeFile testSuccessVC) =<< testSuccessFile dir)+checkTestSuccess dir = do+  fp <- testSuccessFile dir+  -- we could ensure the file is the right size first,+  -- but we're not expected an attack from the user's filesystem+  either (const False) (== successBS)+    <$> tryIO (readFileBinary $ toFilePath fp)  -------------------------------------- -- Precompiled Cache@@ -244,125 +246,89 @@ -- just copy over the executables and reregister the libraries. -------------------------------------- --- | The file containing information on the given package/configuration--- combination. The filename contains a hash of the non-directory configure+-- | The key containing information on the given package/configuration+-- combination. The key contains a hash of the non-directory configure -- options for quick lookup if there's a match. ----- It also returns an action yielding the location of the precompiled--- path based on the old binary encoding.--- -- We only pay attention to non-directory options. We don't want to avoid a -- cache hit just because it was installed in a different directory.-precompiledCacheFile :: HasEnvConfig env-                     => PackageLocationIndex FilePath-                     -> ConfigureOpts-                     -> Set GhcPkgId -- ^ dependencies-                     -> RIO env (Maybe (Path Abs File))-precompiledCacheFile loc copts installedPackageIDs = do-  ec <- view envConfigL--  compiler <- view actualCompilerVersionL >>= parseRelDir . compilerVersionString-  cabal <- view cabalVersionL >>= parseRelDir . versionString-  let mpkgRaw =-        -- The goal here is to come up with a string representing the-        -- package location which is unique. For archives and repos,-        -- we rely upon cryptographic hashes paired with-        -- subdirectories to identify this specific package version.-        case loc of-          PLIndex pir -> Just $ packageIdentifierRevisionString pir-          PLOther other -> case other of-            PLFilePath _ -> assert False Nothing -- no PLFilePaths should end up in a snapshot-            PLArchive a -> fmap-              (\h -> T.unpack (staticSHA256ToText h) ++ archiveSubdirs a)-              (archiveHash a)-            PLRepo r -> Just $ T.unpack (repoCommit r) ++ repoSubdirs r--  forM mpkgRaw $ \pkgRaw -> do-    platformRelDir <- platformGhcRelDir-    let precompiledDir =-              view stackRootL ec-          </> $(mkRelDir "precompiled")-          </> platformRelDir-          </> compiler-          </> cabal+getPrecompiledCacheKey :: HasEnvConfig env+                    => PackageLocationImmutable+                    -> ConfigureOpts+                    -> Bool -- ^ build haddocks+                    -> Set GhcPkgId -- ^ dependencies+                    -> RIO env PrecompiledCacheKey+getPrecompiledCacheKey loc copts buildHaddocks installedPackageIDs = do+  compiler <- view actualCompilerVersionL+  cabalVersion <- view cabalVersionL -    pkg <--      case parseRelDir pkgRaw of-        Just x -> return x-        Nothing -> parseRelDir-                 $ T.unpack-                 $ TE.decodeUtf8-                 $ B64URL.encode-                 $ TE.encodeUtf8-                 $ T.pack pkgRaw+  -- The goal here is to come up with a string representing the+  -- package location which is unique. Luckily @TreeKey@s are exactly+  -- that!+  treeKey <- getPackageLocationTreeKey loc+  let packageKey = utf8BuilderToText $ display treeKey -    -- In Cabal versions 1.22 and later, the configure options contain the-    -- installed package IDs, which is what we need for a unique hash.-    -- Unfortunately, earlier Cabals don't have the information, so we must-    -- supplement it with the installed package IDs directly.-    -- See issue: https://github.com/commercialhaskell/stack/issues/1103-    let input = (coNoDirs copts, installedPackageIDs)-    hashPath <- parseRelFile $ S8.unpack $ B64URL.encode-              $ Mem.convert $ hashWith SHA256 $ Store.encode input+  platformGhcDir <- platformGhcRelDir -    let longPath = precompiledDir </> pkg </> hashPath+  -- In Cabal versions 1.22 and later, the configure options contain the+  -- installed package IDs, which is what we need for a unique hash.+  -- Unfortunately, earlier Cabals don't have the information, so we must+  -- supplement it with the installed package IDs directly.+  -- See issue: https://github.com/commercialhaskell/stack/issues/1103+  let input = (coNoDirs copts, installedPackageIDs)+      optionsHash = Mem.convert $ hashWith SHA256 $ encodeUtf8 $ tshow input -    -- See #3649 - shorten the paths on windows if MAX_PATH will be-    -- violated. Doing this only when necessary allows use of existing-    -- precompiled packages.-    if pathTooLong (toFilePath longPath) then do-        shortPkg <- shaPath pkg-        shortHash <- shaPath hashPath-        return $ precompiledDir </> shortPkg </> shortHash-    else-        return longPath+  return $ precompiledCacheKey platformGhcDir compiler cabalVersion packageKey optionsHash buildHaddocks  -- | Write out information about a newly built package writePrecompiledCache :: HasEnvConfig env                       => BaseConfigOpts-                      -> PackageLocationIndex FilePath+                      -> PackageLocationImmutable                       -> ConfigureOpts+                      -> Bool -- ^ build haddocks                       -> Set GhcPkgId -- ^ dependencies                       -> Installed -- ^ library                       -> [GhcPkgId] -- ^ sublibraries, in the GhcPkgId format                       -> Set Text -- ^ executables                       -> RIO env ()-writePrecompiledCache baseConfigOpts loc copts depIDs mghcPkgId sublibs exes = do-  mfile <- precompiledCacheFile loc copts depIDs-  forM_ mfile $ \file -> do-    ensureDir (parent file)-    ec <- view envConfigL-    let stackRootRelative = makeRelative (view stackRootL ec)-    mlibpath <- case mghcPkgId of-      Executable _ -> return Nothing-      Library _ ipid _ -> liftM Just $ pathFromPkgId stackRootRelative ipid-    sublibpaths <- mapM (pathFromPkgId stackRootRelative) sublibs-    exes' <- forM (Set.toList exes) $ \exe -> do-        name <- parseRelFile $ T.unpack exe-        relPath <- stackRootRelative $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name-        return $ toFilePath relPath-    $(versionedEncodeFile precompiledCacheVC) file PrecompiledCache+writePrecompiledCache baseConfigOpts loc copts buildHaddocks depIDs mghcPkgId sublibs exes = do+  key <- getPrecompiledCacheKey loc copts buildHaddocks depIDs+  ec <- view envConfigL+  let stackRootRelative = makeRelative (view stackRootL ec)+  mlibpath <- case mghcPkgId of+    Executable _ -> return Nothing+    Library _ ipid _ -> Just <$> pathFromPkgId stackRootRelative ipid+  sublibpaths <- mapM (pathFromPkgId stackRootRelative) sublibs+  exes' <- forM (Set.toList exes) $ \exe -> do+      name <- parseRelFile $ T.unpack exe+      stackRootRelative $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name+  let precompiled = PrecompiledCache         { pcLibrary = mlibpath         , pcSubLibs = sublibpaths         , pcExes = exes'         }+  savePrecompiledCache key precompiled+  -- reuse precompiled cache with haddocks also in case when haddocks are not required+  when buildHaddocks $ do+    key' <- getPrecompiledCacheKey loc copts False depIDs+    savePrecompiledCache key' precompiled   where     pathFromPkgId stackRootRelative ipid = do       ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf"-      relPath <- stackRootRelative $ bcoSnapDB baseConfigOpts </> ipid'-      return $ toFilePath relPath+      stackRootRelative $ bcoSnapDB baseConfigOpts </> ipid'  -- | Check the cache for a precompiled package matching the given -- configuration. readPrecompiledCache :: forall env. HasEnvConfig env-                     => PackageLocationIndex FilePath -- ^ target package+                     => PackageLocationImmutable -- ^ target package                      -> ConfigureOpts+                     -> Bool -- ^ build haddocks                      -> Set GhcPkgId -- ^ dependencies-                     -> RIO env (Maybe PrecompiledCache)-readPrecompiledCache loc copts depIDs = runMaybeT $-    MaybeT (precompiledCacheFile loc copts depIDs) >>=-    MaybeT . $(versionedDecodeFile precompiledCacheVC) >>=-    lift . mkAbs+                     -> RIO env (Maybe (PrecompiledCache Abs))+readPrecompiledCache loc copts buildHaddocks depIDs = do+    key <- getPrecompiledCacheKey loc copts buildHaddocks depIDs+    mcache <- loadPrecompiledCache key+    maybe (pure Nothing) (fmap Just . mkAbs) mcache   where     -- Since commit ed9ccc08f327bad68dd2d09a1851ce0d055c0422,     -- pcLibrary paths are stored as relative to the stack@@ -370,29 +336,13 @@     -- checking that the file exists. For the older cached paths, the     -- file will contain an absolute path, which will make `stackRoot     -- </>` a no-op.-    mkAbs :: PrecompiledCache -> RIO env PrecompiledCache+    mkAbs :: PrecompiledCache Rel -> RIO env (PrecompiledCache Abs)     mkAbs pc0 = do       stackRoot <- view stackRootL-      let mkAbs' = (toFilePath stackRoot FP.</>)+      let mkAbs' = (stackRoot </>)       return PrecompiledCache         { pcLibrary = mkAbs' <$> pcLibrary pc0         , pcSubLibs = mkAbs' <$> pcSubLibs pc0         , pcExes = mkAbs' <$> pcExes pc0         } --- | Check if a filesystem path is too long.-pathTooLong :: FilePath -> Bool-#ifdef mingw32_HOST_OS-pathTooLong path = utf16StringLength path >= win32MaxPath-  where-    win32MaxPath = 260-    -- Calculate the length of a string in 16-bit units-    -- if it were converted to utf-16.-    utf16StringLength :: String -> Integer-    utf16StringLength = sum . map utf16CharLength-      where-        utf16CharLength c | ord c < 0x10000 = 1-                          | otherwise       = 2-#else-pathTooLong _ = False-#endif
src/Stack/Build/ConstructPlan.hs view
@@ -1,28 +1,21 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE StandaloneDeriving #-} -- | Construct a @Plan@ for how to build module Stack.Build.ConstructPlan     ( constructPlan     ) where -import           Stack.Prelude hiding (Display (..))+import           Stack.Prelude hiding (Display (..), loadPackage) import           Control.Monad.RWS.Strict hiding ((<>)) import           Control.Monad.State.Strict (execState)-import qualified Data.HashSet as HashSet-import qualified Data.HashMap.Strict as HashMap import           Data.List import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map@@ -34,7 +27,11 @@ import qualified Distribution.Text as Cabal import qualified Distribution.Version as Cabal import           Distribution.Types.BuildType (BuildType (Configure))+import           Distribution.Types.PackageId (pkgVersion)+import           Distribution.Types.PackageName (mkPackageName)+import           Distribution.Version (mkVersion) import           Generics.Deriving.Monoid (memptydefault, mappenddefault)+import           Path (parent) import qualified RIO import           Stack.Build.Cache import           Stack.Build.Haddock@@ -43,32 +40,28 @@ import           Stack.Constants import           Stack.Package import           Stack.PackageDump-import           Stack.PackageIndex-import           Stack.PrettyPrint+import           Stack.SourceMap import           Stack.Types.Build-import           Stack.Types.BuildPlan import           Stack.Types.Compiler import           Stack.Types.Config-import           Stack.Types.FlagName import           Stack.Types.GhcPkgId import           Stack.Types.NamedComponent import           Stack.Types.Package-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Runner+import           Stack.Types.SourceMap import           Stack.Types.Version+import           System.Environment (lookupEnv) import           System.IO (putStrLn)+import           RIO.PrettyPrint import           RIO.Process (findExecutable, HasProcessContext (..))  data PackageInfo     =       -- | This indicates that the package is already installed, and-      -- that we shouldn't build it from source. This is always the case-      -- for snapshot packages.+      -- that we shouldn't build it from source. This is only the case+      -- for global packages.       PIOnlyInstalled InstallLocation Installed       -- | This indicates that the package isn't installed, and we know-      -- where to find its source (either a hackage package or a local-      -- directory).+      -- where to find its source.     | PIOnlySource PackageSource       -- | This indicates that the package is installed and we know       -- where to find its source. We may want to reinstall from source.@@ -79,8 +72,7 @@                        -> (InstallLocation, Installed)                        -> PackageInfo combineSourceInstalled ps (location, installed) =-    assert (piiVersion ps == installedVersion installed) $-    assert (piiLocation ps == location) $+    assert (psVersion ps == installedVersion installed) $     case location of         -- Always trust something in the snapshot         Snap -> PIOnlyInstalled location installed@@ -88,7 +80,7 @@  type CombinedMap = Map PackageName PackageInfo -combineMap :: SourceMap -> InstalledMap -> CombinedMap+combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap combineMap = Map.mergeWithKey     (\_ s i -> Just $ combineSourceInstalled s i)     (fmap PIOnlySource)@@ -107,8 +99,6 @@     -- ^ executable to be installed, and location where the binary is placed     , wDirty :: !(Map PackageName Text)     -- ^ why a local package is considered dirty-    , wDeps :: !(Set PackageName)-    -- ^ Packages which count as dependencies     , wWarnings :: !([Text] -> [Text])     -- ^ Warnings     , wParents :: !ParentMap@@ -127,16 +117,15 @@     IO  data Ctx = Ctx-    { ls             :: !LoadedSnapshot-    , baseConfigOpts :: !BaseConfigOpts-    , loadPackage    :: !(PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> M Package)+    { baseConfigOpts :: !BaseConfigOpts+    , loadPackage    :: !(PackageLocationImmutable -> Map FlagName Bool -> [Text] -> [Text] -> M Package)     , combinedMap    :: !CombinedMap     , ctxEnvConfig   :: !EnvConfig     , callStack      :: ![PackageName]-    , extraToBuild   :: !(Set PackageName)-    , getVersions    :: !(PackageName -> IO (HashMap Version (Maybe CabalHash)))     , wanted         :: !(Set PackageName)     , localNames     :: !(Set PackageName)+    , mcurator       :: !(Maybe Curator)+    , pathEnvVar     :: !Text     }  instance HasPlatform Ctx@@ -145,12 +134,21 @@     logFuncL = configL.logFuncL instance HasRunner Ctx where     runnerL = configL.runnerL+instance HasStylesUpdate Ctx where+  stylesUpdateL = runnerL.stylesUpdateL+instance HasTerm Ctx where+  useColorL = runnerL.useColorL+  termWidthL = runnerL.termWidthL instance HasConfig Ctx-instance HasCabalLoader Ctx where-    cabalLoaderL = configL.cabalLoaderL+instance HasPantryConfig Ctx where+    pantryConfigL = configL.pantryConfigL instance HasProcessContext Ctx where     processContextL = configL.processContextL instance HasBuildConfig Ctx+instance HasSourceMap Ctx where+    sourceMapL = envConfigL.sourceMapL+instance HasCompiler Ctx where+    compilerPathsL = envConfigL.compilerPathsL instance HasEnvConfig Ctx where     envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) @@ -171,30 +169,29 @@ -- 3) It will only rebuild a local package if its files are dirty or -- some of its dependencies have changed. constructPlan :: forall env. HasEnvConfig env-              => LoadedSnapshot-              -> BaseConfigOpts-              -> [LocalPackage]-              -> Set PackageName -- ^ additional packages that must be built-              -> [DumpPackage () () ()] -- ^ locally registered-              -> (PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> RIO EnvConfig Package) -- ^ load upstream package+              => BaseConfigOpts+              -> [DumpPackage] -- ^ locally registered+              -> (PackageLocationImmutable -> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package) -- ^ load upstream package               -> SourceMap               -> InstalledMap               -> Bool               -> RIO env Plan-constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = do+constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = do     logDebug "Constructing the build plan" -    bconfig <- view buildConfigL-    when (hasBaseInDeps bconfig) $+    when hasBaseInDeps $       prettyWarn $ flow "You are trying to upgrade/downgrade base, which is almost certainly not what you really want. Please, consider using another GHC version if you need a certain version of base, or removing base from extra-deps. See more at https://github.com/commercialhaskell/stack/issues/3940." <> line      econfig <- view envConfigL-    let onWanted = void . addDep False . packageName . lpPackage-    let inner = do-            mapM_ onWanted $ filter lpWanted locals-            mapM_ (addDep False) $ Set.toList extraToBuild0-    let ctx = mkCtx econfig-    ((), m, W efinals installExes dirtyReason deps warnings parents) <-+    globalCabalVersion <- view $ compilerPathsL.to cpCabalVersion+    sources <- getSources globalCabalVersion+    mcur <- view $ buildConfigL.to bcCurator++    let onTarget = void . addDep+    let inner = mapM_ onTarget $ Map.keys (smtTargets $ smTargets sourceMap)+    pathEnvVar' <- liftIO $ maybe mempty T.pack <$> lookupEnv "PATH"+    let ctx = mkCtx econfig globalCabalVersion sources mcur pathEnvVar'+    ((), m, W efinals installExes dirtyReason warnings parents) <-         liftIO $ runRWST inner ctx M.empty     mapM_ (logWarn . RIO.display) (warnings [])     let toEither (_, Left e)  = Left e@@ -211,11 +208,11 @@                     case boptsCLIBuildSubset $ bcoBuildOptsCLI baseConfigOpts0 of                         BSAll -> id                         BSOnlySnapshot -> stripLocals-                        BSOnlyDependencies -> stripNonDeps deps+                        BSOnlyDependencies -> stripNonDeps (M.keysSet $ smDeps sourceMap)             return $ takeSubset Plan                 { planTasks = tasks                 , planFinals = M.fromList finals-                , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps+                , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason localDumpPkgs initialBuildSteps                 , planInstallExes =                     if boptsInstallExes (bcoBuildOpts baseConfigOpts0) ||                        boptsInstallCompilerTool (bcoBuildOpts baseConfigOpts0)@@ -226,31 +223,58 @@             planDebug $ show errs             stackYaml <- view stackYamlL             stackRoot <- view stackRootL-            prettyErrorNoIndent $ pprintExceptions errs stackYaml stackRoot parents (wanted ctx)+            prettyErrorNoIndent $+                pprintExceptions errs stackYaml stackRoot parents (wanted ctx) prunedGlobalDeps             throwM $ ConstructPlanFailed "Plan construction failed."   where-    hasBaseInDeps bconfig =-        elem $(mkPackageName "base")-      $ map (packageIdentifierName . pirIdent) [i | (PLIndex i) <- bcDependencies bconfig]+    hasBaseInDeps = Map.member (mkPackageName "base") (smDeps sourceMap) -    mkCtx econfig = Ctx-        { ls = ls0-        , baseConfigOpts = baseConfigOpts0-        , loadPackage = \x y z -> runRIO econfig $ loadPackage0 x y z-        , combinedMap = combineMap sourceMap installedMap+    mkCtx econfig globalCabalVersion sources mcur pathEnvVar' = Ctx+        { baseConfigOpts = baseConfigOpts0+        , loadPackage = \w x y z -> runRIO econfig $+            applyForceCustomBuild globalCabalVersion <$> loadPackage0 w x y z+        , combinedMap = combineMap sources installedMap         , ctxEnvConfig = econfig         , callStack = []-        , extraToBuild = extraToBuild0-        , getVersions = runRIO econfig . getPackageVersions-        , wanted = wantedLocalPackages locals <> extraToBuild0-        , localNames = Set.fromList $ map (packageName . lpPackage) locals+        , wanted = Map.keysSet (smtTargets $ smTargets sourceMap)+        , localNames = Map.keysSet (smProject sourceMap)+        , mcurator = mcur+        , pathEnvVar = pathEnvVar'         } +    prunedGlobalDeps = flip Map.mapMaybe (smGlobal sourceMap) $ \gp ->+      case gp of+         ReplacedGlobalPackage deps ->+           let pruned = filter (not . inSourceMap) deps+           in if null pruned then Nothing else Just pruned+         GlobalPackage _ -> Nothing++    inSourceMap pname = pname `Map.member` smDeps sourceMap ||+                        pname `Map.member` smProject sourceMap++    getSources globalCabalVersion = do+      let loadLocalPackage' pp = do+            lp <- loadLocalPackage pp+            pure lp { lpPackage = applyForceCustomBuild globalCabalVersion $ lpPackage lp }+      pPackages <- for (smProject sourceMap) $ \pp -> do+        lp <- loadLocalPackage' pp+        return $ PSFilePath lp+      bopts <- view $ configL.to configBuild+      deps <- for (smDeps sourceMap) $ \dp ->+        case dpLocation dp of+          PLImmutable loc ->+            return $ PSRemote loc (getPLIVersion loc) (dpFromSnapshot dp) (dpCommon dp)+          PLMutable dir -> do+            pp <- mkProjectPackage YesPrintWarnings dir (shouldHaddockDeps bopts)+            lp <- loadLocalPackage' pp+            return $ PSFilePath lp+      return $ pPackages <> deps+ -- | State to be maintained during the calculation of local packages -- to unregister. data UnregisterState = UnregisterState     { usToUnregister :: !(Map GhcPkgId (PackageIdentifier, Text))-    , usKeep :: ![DumpPackage () () ()]+    , usKeep :: ![DumpPackage]     , usAnyAdded :: !Bool     } @@ -260,14 +284,13 @@                   -- ^ Tasks                   -> Map PackageName Text                   -- ^ Reasons why packages are dirty and must be rebuilt-                  -> [DumpPackage () () ()]+                  -> [DumpPackage]                   -- ^ Local package database dump-                  -> SourceMap                   -> Bool                   -- ^ If true, we're doing a special initialBuildSteps                   -- build - don't unregister target packages.                   -> Map GhcPkgId (PackageIdentifier, Text)-mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps =+mkUnregisterLocal tasks dirtyReason localDumpPkgs initialBuildSteps =     -- We'll take multiple passes through the local packages. This     -- will allow us to detect that a package should be unregistered,     -- as well as all packages directly or transitively depending on@@ -316,16 +339,14 @@           = if initialBuildSteps && taskIsTarget task && taskProvides task == ident               then Nothing               else Just $ fromMaybe "" $ Map.lookup name dirtyReason-      -- Check if we're no longer using the local version-      | Just (piiLocation -> Snap) <- Map.lookup name sourceMap-          = Just "Switching to snapshot installed package"       -- Check if a dependency is going to be unregistered       | (dep, _):_ <- mapMaybe (`Map.lookup` toUnregister) deps-          = Just $ "Dependency being unregistered: " <> packageIdentifierText dep+          = Just $ "Dependency being unregistered: " <> T.pack (packageIdentifierString dep)       -- None of the above, keep it!       | otherwise = Nothing       where-        name = packageIdentifierName ident+        name :: PackageName+        name = pkgName ident  -- | Given a 'LocalPackage' and its 'lpTestBench', adds a 'Task' for -- running its tests and benchmarks.@@ -338,9 +359,9 @@ -- benchmarks. If @isAllInOne@ is 'True' (the common case), then all of -- these should have already been taken care of as part of the build -- step.-addFinal :: LocalPackage -> Package -> Bool -> M ()-addFinal lp package isAllInOne = do-    depsRes <- addPackageDeps False package+addFinal :: LocalPackage -> Package -> Bool -> Bool -> M ()+addFinal lp package isAllInOne buildHaddocks = do+    depsRes <- addPackageDeps package     res <- case depsRes of         Left e -> return $ Left e         Right (missing, present, _minLoc) -> do@@ -356,12 +377,13 @@                             (baseConfigOpts ctx)                             allDeps                             True -- local-                            Local+                            Mutable                             package+                , taskBuildHaddock = buildHaddocks                 , taskPresent = present-                , taskType = TTFiles lp Local -- FIXME we can rely on this being Local, right?+                , taskType = TTLocalMutable lp                 , taskAllInOne = isAllInOne-                , taskCachePkgSrc = CacheSrcLocal (toFilePath (lpDir lp))+                , taskCachePkgSrc = CacheSrcLocal (toFilePath (parent (lpCabalFile lp)))                 , taskAnyMissing = not $ Set.null missing                 , taskBuildTypeConfig = packageBuildTypeConfig package                 }@@ -377,13 +399,10 @@ -- forcing this package to be marked as a dependency, even if it is -- directly wanted. This makes sense - if we left out packages that are -- deps, it would break the --only-dependencies build plan.-addDep :: Bool -- ^ is this being used by a dependency?-       -> PackageName+addDep :: PackageName        -> M (Either ConstructPlanException AddDepRes)-addDep treatAsDep' name = do+addDep name = do     ctx <- ask-    let treatAsDep = treatAsDep' || name `Set.notMember` wanted ctx-    when treatAsDep $ markAsDep name     m <- get     case Map.lookup name m of         Just res -> do@@ -405,36 +424,53 @@                             -- FIXME Slightly hacky, no flags since                             -- they likely won't affect executable                             -- names. This code does not feel right.-                            tellExecutablesUpstream-                              (PackageIdentifierRevision (PackageIdentifier name (installedVersion installed)) CFILatest)-                              loc-                              Map.empty+                            let version = installedVersion installed+                                askPkgLoc = liftRIO $ do+                                  mrev <- getLatestHackageRevision YesRequireHackageIndex name version+                                  case mrev of+                                    Nothing -> do+                                      -- this could happen for GHC boot libraries missing from Hackage+                                      logWarn $ "No latest package revision found for: " <>+                                          fromString (packageNameString name) <> ", dependency callstack: " <>+                                          displayShow (map packageNameString $ callStack ctx)+                                      return Nothing+                                    Just (_rev, cfKey, treeKey) ->+                                      return . Just $+                                          PLIHackage (PackageIdentifier name version) cfKey treeKey+                            tellExecutablesUpstream name askPkgLoc loc Map.empty                             return $ Right $ ADRFound loc installed                         Just (PIOnlySource ps) -> do-                            tellExecutables ps-                            installPackage treatAsDep name ps Nothing+                            tellExecutables name ps+                            installPackage name ps Nothing                         Just (PIBoth ps installed) -> do-                            tellExecutables ps-                            installPackage treatAsDep name ps (Just installed)+                            tellExecutables name ps+                            installPackage name ps (Just installed)             updateLibMap name res             return res  -- FIXME what's the purpose of this? Add a Haddock!-tellExecutables :: PackageSource -> M ()-tellExecutables (PSFiles lp _)+tellExecutables :: PackageName -> PackageSource -> M ()+tellExecutables _name (PSFilePath lp)     | lpWanted lp = tellExecutablesPackage Local $ lpPackage lp     | otherwise = return () -- Ignores ghcOptions because they don't matter for enumerating -- executables.-tellExecutables (PSIndex loc flags _ghcOptions pir) =-    tellExecutablesUpstream pir loc flags+tellExecutables name (PSRemote pkgloc _version _fromSnaphot cp) =+    tellExecutablesUpstream name (pure $ Just pkgloc) Snap (cpFlags cp) -tellExecutablesUpstream :: PackageIdentifierRevision -> InstallLocation -> Map FlagName Bool -> M ()-tellExecutablesUpstream pir@(PackageIdentifierRevision (PackageIdentifier name _) _) loc flags = do+tellExecutablesUpstream ::+       PackageName+    -> M (Maybe PackageLocationImmutable)+    -> InstallLocation+    -> Map FlagName Bool+    -> M ()+tellExecutablesUpstream name retrievePkgLoc loc flags = do     ctx <- ask-    when (name `Set.member` extraToBuild ctx) $ do-        p <- loadPackage ctx (PLIndex pir) flags []-        tellExecutablesPackage loc p+    when (name `Set.member` wanted ctx) $ do+        mPkgLoc <- retrievePkgLoc+        forM_ mPkgLoc $ \pkgLoc -> do+            p <- loadPackage ctx pkgLoc flags [] []+            tellExecutablesPackage loc p  tellExecutablesPackage :: InstallLocation -> Package -> M () tellExecutablesPackage loc p = do@@ -447,10 +483,10 @@                 Just (PIOnlySource ps) -> goSource ps                 Just (PIBoth ps _) -> goSource ps -        goSource (PSFiles lp _)+        goSource (PSFilePath lp)             | lpWanted lp = exeComponents (lpComponents lp)             | otherwise = Set.empty-        goSource PSIndex{} = Set.empty+        goSource PSRemote{} = Set.empty      tell mempty { wInstall = Map.fromList $ map (, loc) $ Set.toList $ filterComps myComps $ packageExes p }   where@@ -460,30 +496,29 @@  -- | Given a 'PackageSource' and perhaps an 'Installed' value, adds -- build 'Task's for the package and its dependencies.-installPackage :: Bool -- ^ is this being used by a dependency?-               -> PackageName+installPackage :: PackageName                -> PackageSource                -> Maybe Installed                -> M (Either ConstructPlanException AddDepRes)-installPackage treatAsDep name ps minstalled = do+installPackage name ps minstalled = do     ctx <- ask     case ps of-        PSIndex _ flags ghcOptions pkgLoc -> do+        PSRemote pkgLoc _version _fromSnaphot cp -> do             planDebug $ "installPackage: Doing all-in-one build for upstream package " ++ show name-            package <- loadPackage ctx (PLIndex pkgLoc) flags ghcOptions -- FIXME be more efficient! Get this from the LoadedPackageInfo!-            resolveDepsAndInstall True treatAsDep ps package minstalled-        PSFiles lp _ ->+            package <- loadPackage ctx pkgLoc (cpFlags cp) (cpGhcOptions cp) (cpCabalConfigOpts cp)+            resolveDepsAndInstall True (cpHaddocks cp) ps package minstalled+        PSFilePath lp -> do             case lpTestBench lp of                 Nothing -> do                     planDebug $ "installPackage: No test / bench component for " ++ show name ++ " so doing an all-in-one build."-                    resolveDepsAndInstall True treatAsDep ps (lpPackage lp) minstalled+                    resolveDepsAndInstall True (lpBuildHaddocks lp) ps (lpPackage lp) minstalled                 Just tb -> do                     -- Attempt to find a plan which performs an all-in-one                     -- build.  Ignore the writer action + reset the state if                     -- it fails.                     s <- get                     res <- pass $ do-                        res <- addPackageDeps treatAsDep tb+                        res <- addPackageDeps tb                         let writerFunc w = case res of                                 Left _ -> mempty                                 _ -> w@@ -491,10 +526,18 @@                     case res of                         Right deps -> do                           planDebug $ "installPackage: For " ++ show name ++ ", successfully added package deps"-                          adr <- installPackageGivenDeps True ps tb minstalled deps+                          -- in curator builds we can't do all-in-one build as test/benchmark failure+                          -- could prevent library from being available to its dependencies+                          -- but when it's already available it's OK to do that+                          splitRequired <- expectedTestOrBenchFailures <$> asks mcurator+                          let isAllInOne = not splitRequired+                          adr <- installPackageGivenDeps isAllInOne (lpBuildHaddocks lp) ps tb minstalled deps+                          let finalAllInOne = case adr of+                                ADRToInstall _ | splitRequired -> False+                                _ -> True                           -- FIXME: this redundantly adds the deps (but                           -- they'll all just get looked up in the map)-                          addFinal lp tb True+                          addFinal lp tb finalAllInOne False                           return $ Right adr                         Left _ -> do                             -- Reset the state to how it was before@@ -504,13 +547,18 @@                             put s                             -- Otherwise, fall back on building the                             -- tests / benchmarks in a separate step.-                            res' <- resolveDepsAndInstall False treatAsDep ps (lpPackage lp) minstalled+                            res' <- resolveDepsAndInstall False (lpBuildHaddocks lp) ps (lpPackage lp) minstalled                             when (isRight res') $ do                                 -- Insert it into the map so that it's                                 -- available for addFinal.                                 updateLibMap name res'-                                addFinal lp tb False+                                addFinal lp tb False False                             return res'+ where+   expectedTestOrBenchFailures maybeCurator = fromMaybe False $ do+     curator <- maybeCurator+     pure $ Set.member name (curatorExpectTestFailure curator) ||+            Set.member name (curatorExpectBenchmarkFailure curator)  resolveDepsAndInstall :: Bool                       -> Bool@@ -518,58 +566,61 @@                       -> Package                       -> Maybe Installed                       -> M (Either ConstructPlanException AddDepRes)-resolveDepsAndInstall isAllInOne treatAsDep ps package minstalled = do-    res <- addPackageDeps treatAsDep package+resolveDepsAndInstall isAllInOne buildHaddocks ps package minstalled = do+    res <- addPackageDeps package     case res of         Left err -> return $ Left err-        Right deps -> liftM Right $ installPackageGivenDeps isAllInOne ps package minstalled deps+        Right deps -> liftM Right $ installPackageGivenDeps isAllInOne buildHaddocks ps package minstalled deps  -- | Checks if we need to install the given 'Package', given the results -- of 'addPackageDeps'. If dependencies are missing, the package is -- dirty, or it's not installed, then it needs to be installed. installPackageGivenDeps :: Bool+                        -> Bool                         -> PackageSource                         -> Package                         -> Maybe Installed                         -> ( Set PackageIdentifier                            , Map PackageIdentifier GhcPkgId-                           , InstallLocation )+                           , IsMutable )                         -> M AddDepRes-installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minLoc) = do+installPackageGivenDeps isAllInOne buildHaddocks ps package minstalled (missing, present, minMutable) = do     let name = packageName package     ctx <- ask     mRightVersionInstalled <- case (minstalled, Set.null missing) of         (Just installed, True) -> do-            shouldInstall <- checkDirtiness ps installed package present (wanted ctx)+            shouldInstall <- checkDirtiness ps installed package present buildHaddocks             return $ if shouldInstall then Nothing else Just installed         (Just _, False) -> do-            let t = T.intercalate ", " $ map (T.pack . packageNameString . packageIdentifierName) (Set.toList missing)+            let t = T.intercalate ", " $ map (T.pack . packageNameString . pkgName) (Set.toList missing)             tell mempty { wDirty = Map.singleton name $ "missing dependencies: " <> addEllipsis t }             return Nothing         (Nothing, _) -> return Nothing+    let loc = psLocation ps+        mutable = installLocationIsMutable loc <> minMutable     return $ case mRightVersionInstalled of-        Just installed -> ADRFound (piiLocation ps) installed+        Just installed -> ADRFound loc installed         Nothing -> ADRToInstall Task             { taskProvides = PackageIdentifier                 (packageName package)                 (packageVersion package)             , taskConfigOpts = TaskConfigOpts missing $ \missing' ->                 let allDeps = Map.union present missing'-                    destLoc = piiLocation ps <> minLoc                  in configureOpts                         (view envConfigL ctx)                         (baseConfigOpts ctx)                         allDeps                         (psLocal ps)-                        -- An assertion to check for a recurrence of-                        -- https://github.com/commercialhaskell/stack/issues/345-                        (assert (destLoc == piiLocation ps) destLoc)+                        mutable                         package+            , taskBuildHaddock = buildHaddocks             , taskPresent = present             , taskType =                 case ps of-                    PSFiles lp loc -> TTFiles lp (loc <> minLoc)-                    PSIndex loc _ _ pkgLoc -> TTIndex package (loc <> minLoc) pkgLoc+                    PSFilePath lp ->+                      TTLocalMutable lp+                    PSRemote pkgLoc _version _fromSnaphot _cp ->+                      TTRemotePackage mutable package pkgLoc             , taskAllInOne = isAllInOne             , taskCachePkgSrc = toCachePkgSrc ps             , taskAnyMissing = not $ Set.null missing@@ -603,28 +654,33 @@ -- then the parent package must be installed locally. Otherwise, if it -- is 'Snap', then it can either be installed locally or in the -- snapshot.-addPackageDeps :: Bool -- ^ is this being used by a dependency?-               -> Package -> M (Either ConstructPlanException (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, InstallLocation))-addPackageDeps treatAsDep package = do+addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, IsMutable))+addPackageDeps package = do     ctx <- ask     deps' <- packageDepsWithTools package     deps <- forM (Map.toList deps') $ \(depname, DepValue range depType) -> do-        eres <- addDep treatAsDep depname-        let getLatestApplicableVersionAndRev = do-                vsAndRevs <- liftIO $ getVersions ctx depname-                let vs = Set.fromList (HashMap.keys vsAndRevs)-                case latestApplicableVersion range vs of-                  Nothing -> pure Nothing-                  Just lappVer -> do-                    let mlappRev = join (HashMap.lookup lappVer vsAndRevs)-                    pure $ (lappVer,) <$> mlappRev+        eres <- addDep depname+        let getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey))+            getLatestApplicableVersionAndRev = do+              vsAndRevs <- runRIO ctx $ getHackagePackageVersions YesRequireHackageIndex UsePreferredVersions depname+              pure $ do+                lappVer <- latestApplicableVersion range $ Map.keysSet vsAndRevs+                revs <- Map.lookup lappVer vsAndRevs+                (cabalHash, _) <- Map.maxView revs+                Just (lappVer, cabalHash)         case eres of             Left e -> do                 addParent depname range Nothing                 let bd =                         case e of                             UnknownPackage name -> assert (name == depname) NotInBuildPlan-                            _ -> Couldn'tResolveItsDependencies (packageVersion package)+                            DependencyCycleDetected names -> BDDependencyCycleDetected names+                            -- ultimately we won't show any+                            -- information on this to the user, we'll+                            -- allow the dependency failures alone to+                            -- display to avoid spamming the user too+                            -- much+                            DependencyPlanFailures _ _  -> Couldn'tResolveItsDependencies (packageVersion package)                 mlatestApplicable <- getLatestApplicableVersionAndRev                 return $ Left (depname, (range, mlatestApplicable, bd))             Right adr | depType == AsLibrary && not (adrHasLibrary adr) ->@@ -638,36 +694,40 @@                                 tell mempty { wWarnings = (msg:) }                               where                                 msg = T.concat-                                    [ "WARNING: Ignoring out of range dependency"-                                    , reason-                                    , ": "-                                    , T.pack $ packageIdentifierString $ PackageIdentifier depname (adrVersion adr)-                                    , ". "+                                    [ "WARNING: Ignoring "                                     , T.pack $ packageNameString $ packageName package-                                    , " requires: "+                                    , "'s bounds on "+                                    , T.pack $ packageNameString depname+                                    , " ("                                     , versionRangeText range+                                    , "); using "+                                    , T.pack $ packageIdentifierString $ PackageIdentifier depname (adrVersion adr)+                                    , ".\nReason: "+                                    , reason+                                    , "."                                     ]                         allowNewer <- view $ configL.to configAllowNewer                         if allowNewer                             then do-                                warn_ " (allow-newer enabled)"+                                warn_ "allow-newer enabled"                                 return True                             else do+                                -- We ignore dependency information for packages in a snapshot                                 x <- inSnapshot (packageName package) (packageVersion package)                                 y <- inSnapshot depname (adrVersion adr)                                 if x && y                                     then do-                                        warn_ " (trusting snapshot over Hackage revisions)"+                                        warn_ "trusting snapshot over cabal file dependency information"                                         return True                                     else return False                 if inRange                     then case adr of                         ADRToInstall task -> return $ Right-                            (Set.singleton $ taskProvides task, Map.empty, taskLocation task)+                            (Set.singleton $ taskProvides task, Map.empty, taskTargetIsMutable task)                         ADRFound loc (Executable _) -> return $ Right-                            (Set.empty, Map.empty, loc)+                            (Set.empty, Map.empty, installLocationIsMutable loc)                         ADRFound loc (Library ident gid _) -> return $ Right-                            (Set.empty, Map.singleton ident gid, loc)+                            (Set.empty, Map.singleton ident gid, installLocationIsMutable loc)                     else do                         mlatestApplicable <- getLatestApplicableVersionAndRev                         return $ Left (depname, (range, mlatestApplicable, DependencyMismatch $ adrVersion adr))@@ -682,7 +742,7 @@             package             (Map.fromList errs)   where-    adrVersion (ADRToInstall task) = packageIdentifierVersion $ taskProvides task+    adrVersion (ADRToInstall task) = pkgVersion $ taskProvides task     adrVersion (ADRFound _ installed) = installedVersion installed     -- Update the parents map, for later use in plan construction errors     -- - see 'getShortestDepsPath'.@@ -698,8 +758,8 @@     taskHasLibrary :: Task -> Bool     taskHasLibrary task =       case taskType task of-        TTFiles lp _ -> packageHasLibrary $ lpPackage lp-        TTIndex p _ _ -> packageHasLibrary p+        TTLocalMutable lp -> packageHasLibrary $ lpPackage lp+        TTRemotePackage _ p _ -> packageHasLibrary p      -- make sure we consider internal libraries as libraries too     packageHasLibrary :: Package -> Bool@@ -713,9 +773,9 @@                -> Installed                -> Package                -> Map PackageIdentifier GhcPkgId-               -> Set PackageName+               -> Bool                -> M Bool-checkDirtiness ps installed package present wanted = do+checkDirtiness ps installed package present buildHaddocks = do     ctx <- ask     moldOpts <- runRIO ctx $ tryGetFlagCache installed     let configOpts = configureOpts@@ -723,32 +783,32 @@             (baseConfigOpts ctx)             present             (psLocal ps)-            (piiLocation ps) -- should be Local always+            (installLocationIsMutable $ psLocation ps) -- should be Local i.e. mutable always             package-        buildOpts = bcoBuildOpts (baseConfigOpts ctx)         wantConfigCache = ConfigCache             { configCacheOpts = configOpts             , configCacheDeps = Set.fromList $ Map.elems present             , configCacheComponents =                 case ps of-                    PSFiles lp _ -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp-                    PSIndex{} -> Set.empty-            , configCacheHaddock =-                shouldHaddockPackage buildOpts wanted (packageName package) ||-                -- Disabling haddocks when old config had haddocks doesn't make dirty.-                maybe False configCacheHaddock moldOpts+                    PSFilePath lp -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp+                    PSRemote{} -> Set.empty+            , configCacheHaddock = buildHaddocks             , configCachePkgSrc = toCachePkgSrc ps+            , configCachePathEnvVar = pathEnvVar ctx             }-    let mreason =-            case moldOpts of-                Nothing -> Just "old configure information not found"-                Just oldOpts-                    | Just reason <- describeConfigDiff config oldOpts wantConfigCache -> Just reason-                    | True <- psForceDirty ps -> Just "--force-dirty specified"-                    | Just files <- psDirty ps -> Just $ "local file changes: " <>-                                                         addEllipsis (T.pack $ unwords $ Set.toList files)-                    | otherwise -> Nothing         config = view configL ctx+    mreason <-+      case moldOpts of+        Nothing -> pure $ Just "old configure information not found"+        Just oldOpts+          | Just reason <- describeConfigDiff config oldOpts wantConfigCache -> pure $ Just reason+          | True <- psForceDirty ps -> pure $ Just "--force-dirty specified"+          | otherwise -> do+              dirty <- psDirty ps+              pure $+                case dirty of+                  Just files -> Just $ "local file changes: " <> addEllipsis (T.pack $ unwords $ Set.toList files)+                  Nothing -> Nothing     case mreason of         Nothing -> return False         Just reason -> do@@ -822,17 +882,24 @@     pkgSrcName CacheSrcUpstream = "upstream source"  psForceDirty :: PackageSource -> Bool-psForceDirty (PSFiles lp _) = lpForceDirty lp-psForceDirty PSIndex{} = False+psForceDirty (PSFilePath lp) = lpForceDirty lp+psForceDirty PSRemote{} = False -psDirty :: PackageSource -> Maybe (Set FilePath)-psDirty (PSFiles lp _) = lpDirtyFiles lp-psDirty PSIndex{} = Nothing -- files never change in an upstream package+psDirty+  :: (MonadIO m, HasEnvConfig env, MonadReader env m)+  => PackageSource+  -> m (Maybe (Set FilePath))+psDirty (PSFilePath lp) = runMemoizedWith $ lpDirtyFiles lp+psDirty PSRemote {} = pure Nothing -- files never change in a remote package  psLocal :: PackageSource -> Bool-psLocal (PSFiles _ loc) = loc == Local -- FIXME this is probably not the right logic, see configureOptsNoDir. We probably want to check if this appears in packages:-psLocal PSIndex{} = False+psLocal (PSFilePath _ ) = True+psLocal PSRemote{} = False +psLocation :: PackageSource -> InstallLocation+psLocation (PSFilePath _) = Local+psLocation PSRemote{} = Snap+ -- | Get all of the dependencies for a given package, including build -- tool dependencies. packageDepsWithTools :: Package -> M (Map PackageName DepValue)@@ -856,11 +923,11 @@   deriving Show  toolWarningText :: ToolWarning -> Text-toolWarningText (ToolWarning (ExeName toolName) pkgName) =+toolWarningText (ToolWarning (ExeName toolName) pkgName') =     "No packages found in snapshot which provide a " <>     T.pack (show toolName) <>     " executable, which is a build-tool dependency of " <>-    T.pack (show (packageNameString pkgName))+    T.pack (packageNameString pkgName')  -- | Strip out anything from the @Plan@ intended for the local database stripLocals :: Plan -> Plan@@ -880,33 +947,48 @@     , planInstallExes = Map.empty -- TODO maybe don't disable this?     }   where-    checkTask task = packageIdentifierName (taskProvides task) `Set.member` deps+    checkTask task = taskProvides task `Set.member` missingForDeps+    providesDep task = pkgName (taskProvides task) `Set.member` deps+    missing = Map.fromList $ map (taskProvides &&& tcoMissing . taskConfigOpts) $+              Map.elems (planTasks plan)+    missingForDeps = flip execState mempty $ do+      for_ (Map.elems $ planTasks plan) $ \task ->+        when (providesDep task) $ collectMissing mempty (taskProvides task) -markAsDep :: PackageName -> M ()-markAsDep name = tell mempty { wDeps = Set.singleton name }+    collectMissing dependents pid = do+      when (pid `elem` dependents) $ error $+        "Unexpected: task cycle for " <> packageNameString (pkgName pid)+      modify'(<> Set.singleton pid)+      mapM_ (collectMissing (pid:dependents)) (fromMaybe mempty $ M.lookup pid missing) --- | Is the given package/version combo defined in the snapshot?+-- | Is the given package/version combo defined in the snapshot or in the global database? inSnapshot :: PackageName -> Version -> M Bool inSnapshot name version = do-    p <- asks ls-    ls <- asks localNames+    ctx <- ask     return $ fromMaybe False $ do-        guard $ not $ name `Set.member` ls-        lpi <- Map.lookup name (lsPackages p)-        return $ lpiVersion lpi == version+        ps <- Map.lookup name (combinedMap ctx)+        case ps of+            PIOnlySource (PSRemote _ srcVersion FromSnapshot _) ->+                return $ srcVersion == version+            PIBoth (PSRemote _ srcVersion FromSnapshot _) _ ->+                return $ srcVersion == version+            -- OnlyInstalled occurs for global database+            PIOnlyInstalled loc (Library pid _gid _lic) ->+              assert (loc == Snap) $+              assert (pkgVersion pid == version) $+              Just True+            _ -> return False  data ConstructPlanException     = DependencyCycleDetected [PackageName]     | 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, Ord, Show)--deriving instance Ord VersionRange+    deriving (Typeable, Eq, Show)  -- | The latest applicable version and it's latest cabal file revision. -- For display purposes only, Nothing if package not found-type LatestApplicableVersion = Maybe (Version, CabalHash)+type LatestApplicableVersion = Maybe (Version, BlobKey)  -- | Reason why a dependency was not used data BadDependency@@ -915,6 +997,7 @@     | DependencyMismatch Version     | HasNoLibrary     -- ^ See description of 'DepType'+    | BDDependencyCycleDetected ![PackageName]     deriving (Typeable, Eq, Ord, Show)  -- TODO: Consider intersecting version ranges for multiple deps on a@@ -926,8 +1009,9 @@     -> Path Abs Dir     -> ParentMap     -> Set PackageName-    -> AnsiDoc-pprintExceptions exceptions stackYaml stackRoot parentMap wanted =+    -> Map PackageName [PackageName]+    -> StyleDoc+pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDeps =     mconcat $       [ flow "While constructing the build plan, the following exceptions were encountered:"       , line <> line@@ -937,28 +1021,25 @@       , line <> line       ] ++       (if not onlyHasDependencyMismatches then [] else-         [ "  *" <+> align (flow "Set 'allow-newer: true' in " <+> toAnsiDoc (display (defaultUserConfigPath stackRoot)) <+> "to ignore all version constraints and build anyway.")+         [ "  *" <+> align (flow "Set 'allow-newer: true' in " <+> pretty (defaultUserConfigPath stackRoot) <+> "to ignore all version constraints and build anyway.")          , line <> line          ]-      ) ++-      [ "  *" <+> align (flow "Consider trying 'stack solver', which uses the cabal-install solver to attempt to find some working build configuration. This can be convenient when dealing with many complicated constraint errors, but results may be unpredictable.")-      , line <> line-      ] ++ addExtraDepsRecommendations+      ) ++ addExtraDepsRecommendations    where-    exceptions' = nubOrd exceptions+    exceptions' = {- should we dedupe these somehow? nubOrd -} exceptions      addExtraDepsRecommendations       | Map.null extras = []-      | (Just _) <- Map.lookup $(mkPackageName "base") extras =+      | (Just _) <- Map.lookup (mkPackageName "base") extras =           [ "  *" <+> align (flow "Build requires unattainable version of base. Since base is a part of GHC, you most likely need to use a different GHC version with the matching base.")            , line           ]       | otherwise =          [ "  *" <+> align-           (styleRecommendation (flow "Recommended action:") <+>+           (style Recommendation (flow "Recommended action:") <+>             flow "try adding the following to your extra-deps in" <+>-            toAnsiDoc (display stackYaml) <> ":")+            pretty stackYaml <> ":")          , line <> line          , vsep (map pprintExtra (Map.toList extras))          , line@@ -976,11 +1057,10 @@        go (name, (_range, Just (version,cabalHash), DependencyMismatch{})) =            Map.singleton name (version, cabalHash)        go _ = Map.empty-    pprintExtra (name, (version, cabalHash)) =-      let cfInfo = CFIHash Nothing cabalHash-          packageId = PackageIdentifier name version-          packageIdRev = PackageIdentifierRevision packageId cfInfo-       in fromString $ packageIdentifierRevisionString packageIdRev+    pprintExtra (name, (version, BlobKey cabalHash cabalSize)) =+      let cfInfo = CFIHash cabalHash (Just cabalSize)+          packageIdRev = PackageIdentifierRevision name version cfInfo+       in fromString ("- " ++ T.unpack (utf8BuilderToText (RIO.display packageIdRev)))      allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions'     toNotInBuildPlan (DependencyPlanFailures _ pDeps) =@@ -1000,7 +1080,7 @@      pprintException (DependencyCycleDetected pNames) = Just $         flow "Dependency cycle detected in packages:" <> line <>-        indent 4 (encloseSep "[" "]" "," (map (styleError . display) pNames))+        indent 4 (encloseSep "[" "]" "," (map (style Error . fromString . packageNameString) pNames))     pprintException (DependencyPlanFailures pkg pDeps) =         case mapMaybe pprintDep (Map.toList pDeps) of             [] -> Nothing@@ -1008,34 +1088,41 @@                 flow "In the dependencies for" <+> pkgIdent <>                 pprintFlags (packageFlags pkg) <> ":" <> line <>                 indent 4 (vsep depErrors) <>-                case getShortestDepsPath parentMap wanted (packageName pkg) of+                case getShortestDepsPath parentMap wanted' (packageName pkg) of                     Nothing -> line <> flow "needed for unknown reason - stack invariant violated."-                    Just [] -> line <> flow "needed since" <+> pkgName <+> flow "is a build target."+                    Just [] -> line <> flow "needed since" <+> pkgName' <+> flow "is a build target."                     Just (target:path) -> line <> flow "needed due to" <+> encloseSep "" "" " -> " pathElems                       where                         pathElems =-                            [styleTarget . display $ target] ++-                            map display path +++                            [style Target . fromString . packageIdentifierString $ target] +++                            map (fromString . packageIdentifierString) path ++                             [pkgIdent]               where-                pkgName = styleCurrent . display $ packageName pkg-                pkgIdent = styleCurrent . display $ packageIdentifier pkg+                pkgName' = style Current . fromString . packageNameString $ packageName pkg+                pkgIdent = style Current . fromString . packageIdentifierString $ packageIdentifier pkg     -- Skip these when they are redundant with 'NotInBuildPlan' info.     pprintException (UnknownPackage name)         | name `Set.member` allNotInBuildPlan = Nothing-        | name `HashSet.member` wiredInPackages =-            Just $ flow "Can't build a package with same name as a wired-in-package:" <+> (styleCurrent . display $ name)-        | otherwise = Just $ flow "Unknown package:" <+> (styleCurrent . display $ name)+        | name `Set.member` wiredInPackages =+            Just $ flow "Can't build a package with same name as a wired-in-package:" <+> (style Current . fromString . packageNameString $ name)+        | Just pruned <- Map.lookup name prunedGlobalDeps =+            let prunedDeps = map (style Current . fromString . packageNameString) pruned+            in Just $ flow "Can't use GHC boot package" <+>+                      (style Current . fromString . packageNameString $ name) <+>+                      flow "when it has an overriden dependency, " <+>+                      flow "you need to add the following as explicit dependencies to the project:" <+>+                      line <+> encloseSep "" "" ", " prunedDeps+        | otherwise = Just $ flow "Unknown package:" <+> (style Current . fromString . packageNameString $ name)      pprintFlags flags         | Map.null flags = ""         | otherwise = parens $ sep $ map pprintFlag $ Map.toList flags-    pprintFlag (name, True) = "+" <> fromString (show name)-    pprintFlag (name, False) = "-" <> fromString (show name)+    pprintFlag (name, True) = "+" <> fromString (flagNameString name)+    pprintFlag (name, False) = "-" <> fromString (flagNameString name)      pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of         NotInBuildPlan -> Just $-            styleError (display name) <+>+            style Error (fromString $ packageNameString name) <+>             align ((if range == Cabal.anyVersion                       then flow "needed"                       else flow "must match" <+> goodRange) <> "," <> softline <>@@ -1043,7 +1130,7 @@                    latestApplicable Nothing)         -- TODO: For local packages, suggest editing constraints         DependencyMismatch version -> Just $-            (styleError . display) (PackageIdentifier name version) <+>+            (style Error . fromString . packageIdentifierString) (PackageIdentifier name version) <+>             align (flow "from stack configuration does not match" <+> goodRange <+>                    latestApplicable (Just version))         -- I think the main useful info is these explain why missing@@ -1051,10 +1138,13 @@         -- path from a target to the package.         Couldn'tResolveItsDependencies _version -> Nothing         HasNoLibrary -> Just $-            styleError (display name) <+>+            style Error (fromString $ packageNameString name) <+>             align (flow "is a library dependency, but the package provides no library")+        BDDependencyCycleDetected names -> Just $+            style Error (fromString $ packageNameString name) <+>+            align (flow $ "dependency cycle detected: " ++ intercalate ", " (map packageNameString names))       where-        goodRange = styleGood (fromString (Cabal.display range))+        goodRange = style Good (fromString (Cabal.display range))         latestApplicable mversion =             case mlatestApplicable of                 Nothing@@ -1065,7 +1155,7 @@                     | Just laVer == mversion -> softline <>                         flow "(latest matching version is specified)"                     | otherwise -> softline <>-                        flow "(latest matching version is" <+> styleGood (display laVer) <> ")"+                        flow "(latest matching version is" <+> style Good (fromString $ versionString laVer) <> ")"  -- | Get the shortest reason for the package to be in the build plan. In -- other words, trace the parent dependencies back to a 'wanted'@@ -1075,28 +1165,28 @@     -> Set PackageName     -> PackageName     -> Maybe [PackageIdentifier]-getShortestDepsPath (MonoidMap parentsMap) wanted name =-    if Set.member name wanted+getShortestDepsPath (MonoidMap parentsMap) wanted' name =+    if Set.member name wanted'         then Just []         else case M.lookup name parentsMap of             Nothing -> Nothing             Just (_, parents) -> Just $ findShortest 256 paths0               where-                paths0 = M.fromList $ map (\(ident, _) -> (packageIdentifierName ident, startDepsPath ident)) parents+                paths0 = M.fromList $ map (\(ident, _) -> (pkgName ident, startDepsPath ident)) parents   where     -- The 'paths' map is a map from PackageName to the shortest path     -- found to get there. It is the frontier of our breadth-first     -- search of dependencies.     findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier]     findShortest fuel _ | fuel <= 0 =-        [PackageIdentifier $(mkPackageName "stack-ran-out-of-jet-fuel") $(mkVersion "0")]+        [PackageIdentifier (mkPackageName "stack-ran-out-of-jet-fuel") (mkVersion [0])]     findShortest _ paths | M.null paths = []     findShortest fuel paths =         case targets of             [] -> findShortest (fuel - 1) $ M.fromListWith chooseBest $ concatMap extendPath recurses             _ -> let (DepsPath _ _ path) = minimum (map snd targets) in path       where-        (targets, recurses) = partition (\(n, _) -> n `Set.member` wanted) (M.toList paths)+        (targets, recurses) = partition (\(n, _) -> n `Set.member` wanted') (M.toList paths)     chooseBest :: DepsPath -> DepsPath -> DepsPath     chooseBest x y = if x > y then x else y     -- Extend a path to all its parents.@@ -1104,7 +1194,7 @@     extendPath (n, dp) =         case M.lookup n parentsMap of             Nothing -> []-            Just (_, parents) -> map (\(pkgId, _) -> (packageIdentifierName pkgId, extendDepsPath pkgId dp)) parents+            Just (_, parents) -> map (\(pkgId, _) -> (pkgName pkgId, extendDepsPath pkgId dp)) parents  data DepsPath = DepsPath     { dpLength :: Int -- ^ Length of dpPath@@ -1118,14 +1208,14 @@ startDepsPath :: PackageIdentifier -> DepsPath startDepsPath ident = DepsPath     { dpLength = 1-    , dpNameLength = T.length (packageNameText (packageIdentifierName ident))+    , dpNameLength = length (packageNameString (pkgName ident))     , dpPath = [ident]     }  extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath extendDepsPath ident dp = DepsPath     { dpLength = dpLength dp + 1-    , dpNameLength = dpNameLength dp + T.length (packageNameText (packageIdentifierName ident))+    , dpNameLength = dpNameLength dp + length (packageNameString (pkgName ident))     , dpPath = [ident]     }
src/Stack/Build/Execute.hs view
@@ -1,13 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP                   #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE LambdaCase            #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE RankNTypes            #-}@@ -22,6 +19,7 @@     , withExecuteEnv     , withSingleContext     , ExcludeTHLoading(..)+    , KeepOutputOpen(..)     ) where  import           Control.Concurrent.Execute@@ -31,32 +29,35 @@ import           Data.Attoparsec.Text hiding (try) import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString as S+import qualified Data.ByteString.Builder+import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Base64.URL as B64URL import           Data.Char (isSpace)-import           Data.Conduit+import           Conduit import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.Filesystem as CF import qualified Data.Conduit.List as CL-import           Data.Conduit.Process.Typed-                    (ExitCodeException (..), waitExitCode,-                     useHandleOpen, setStdin, setStdout, setStderr, getStdin,-                     createPipe, runProcess_, getStdout,-                     getStderr, createSource)+import           Data.Conduit.Process.Typed (createSource) import qualified Data.Conduit.Text as CT-import           Data.FileEmbed (embedFile, makeRelativeToProject)-import           Data.IORef.RunOnce (runOnce) import           Data.List hiding (any)+import           Data.List.NonEmpty (NonEmpty(..), nonEmpty)+import qualified Data.List.NonEmpty as NonEmpty (toList)+import           Data.List.Split (chunksOf) import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T import           Data.Text.Encoding (decodeUtf8, encodeUtf8)-import           Data.Time.Clock (getCurrentTime) import           Data.Tuple import qualified Distribution.PackageDescription as C import qualified Distribution.Simple.Build.Macros as C import           Distribution.System            (OS (Windows),                                                  Platform (Platform)) import qualified Distribution.Text as C+import           Distribution.Types.PackageName (mkPackageName)+import           Distribution.Types.UnqualComponentName (mkUnqualComponentName)+import           Distribution.Version (mkVersion)+import           Foreign.C.Types (CTime) import           Path import           Path.CheckInstall import           Path.Extra (toFilePathNoTrailingSep, rejectMissingFile)@@ -71,28 +72,27 @@ import           Stack.Constants import           Stack.Constants.Config import           Stack.Coverage-import           Stack.Fetch as Fetch+import           Stack.DefaultColorWhen (defaultColorWhen) import           Stack.GhcPkg import           Stack.Package 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.NamedComponent import           Stack.Types.Package-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Runner import           Stack.Types.Version import qualified System.Directory as D-import           System.Environment (getExecutablePath)-import           System.Exit (ExitCode (..))+import           System.Environment (getExecutablePath, lookupEnv)+import           System.FileLock (withTryFileLock, SharedExclusive (Exclusive), withFileLock) import qualified System.FilePath as FP-import           System.IO (hPutStr, stderr, stdout)-import           System.PosixCompat.Files (createLink)+import           System.IO (stderr, stdout)+import           System.PosixCompat.Files (createLink, modificationTime, getFileStatus)+import           System.PosixCompat.Time (epochTime)+import           RIO.PrettyPrint import           RIO.Process+import           Pantry.Internal.Companion  -- | Has an executable been built or not? data ExecutableBuildStatus@@ -103,19 +103,19 @@ -- | Fetch the packages necessary for a build, for example in combination with a dry run. preFetch :: HasEnvConfig env => Plan -> RIO env () preFetch plan-    | Set.null idents = logDebug "Nothing to fetch"+    | Set.null pkgLocs = logDebug "Nothing to fetch"     | otherwise = do         logDebug $             "Prefetching: " <>-            mconcat (intersperse ", " (RIO.display <$> Set.toList idents))-        fetchPackages idents+            mconcat (intersperse ", " (RIO.display <$> Set.toList pkgLocs))+        fetchPackages pkgLocs   where-    idents = Set.unions $ map toIdent $ Map.elems $ planTasks plan+    pkgLocs = Set.unions $ map toPkgLoc $ Map.elems $ planTasks plan -    toIdent task =+    toPkgLoc task =         case taskType task of-            TTFiles{} -> Set.empty-            TTIndex _ _ (PackageIdentifierRevision ident _) -> Set.singleton ident+            TTLocalMutable{} -> Set.empty+            TTRemotePackage _ _ pkgloc -> Set.singleton pkgloc  -- | Print a description of build plan for human consumption. printPlan :: HasRunner env => Plan -> RIO env ()@@ -125,7 +125,7 @@         xs -> do             logInfo "Would unregister locally:"             forM_ xs $ \(ident, reason) -> logInfo $-                RIO.display ident <>+                fromString (packageIdentifierString ident) <>                 if T.null reason                   then ""                   else " (" <> RIO.display reason <> ")"@@ -169,19 +169,19 @@ -- | For a dry run displayTask :: Task -> Utf8Builder displayTask task =-    RIO.display (taskProvides task) <>+    fromString (packageIdentifierString (taskProvides task)) <>     ": database=" <>     (case taskLocation task of         Snap -> "snapshot"         Local -> "local") <>     ", source=" <>     (case taskType task of-        TTFiles lp _ -> fromString $ toFilePath $ lpDir lp-        TTIndex{} -> "package index") <>+        TTLocalMutable lp -> fromString $ toFilePath $ parent $ lpCabalFile lp+        TTRemotePackage _ _ pl -> RIO.display pl) <>     (if Set.null missing         then ""         else ", after: " <>-             mconcat (intersperse "," (RIO.display <$> Set.toList missing)))+             mconcat (intersperse "," (fromString . packageIdentifierString <$> Set.toList missing)))   where     missing = tcoMissing $ taskConfigOpts task @@ -201,18 +201,19 @@     -- ^ Compiled version of eeSetupHs     , eeCabalPkgVer    :: !Version     , eeTotalWanted    :: !Int-    , eeWanted         :: !(Set PackageName)     , eeLocals         :: ![LocalPackage]     , eeGlobalDB       :: !(Path Abs Dir)-    , eeGlobalDumpPkgs :: !(Map GhcPkgId (DumpPackage () () ()))-    , eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () () ())))-    , eeLocalDumpPkgs  :: !(TVar (Map GhcPkgId (DumpPackage () () ())))+    , eeGlobalDumpPkgs :: !(Map GhcPkgId DumpPackage)+    , eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId DumpPackage))+    , eeLocalDumpPkgs  :: !(TVar (Map GhcPkgId DumpPackage))     , eeLogFiles       :: !(TChan (Path Abs Dir, Path Abs File))-    , eeGetGhcPath     :: !(forall m. MonadIO m => m (Path Abs File))-    , eeGetGhcjsPath   :: !(forall m. MonadIO m => m (Path Abs File))     , eeCustomBuilt    :: !(IORef (Set PackageName))     -- ^ Stores which packages with custom-setup have already had their     -- Setup.hs built.+    , eeLargestPackageName :: !(Maybe Int)+    -- ^ For nicer interleaved output: track the largest package name size+    , eePathEnvVar :: !Text+    -- ^ Value of the PATH environment variable     }  buildSetupArgs :: [String]@@ -228,18 +229,15 @@      , "StackSetupShim.mainOverride"      ] -setupGhciShimCode :: S.ByteString-setupGhciShimCode = $(do-    path <- makeRelativeToProject "src/setup-shim/StackSetupShim.hs"-    embedFile path)--simpleSetupCode :: S.ByteString+simpleSetupCode :: Builder simpleSetupCode = "import Distribution.Simple\nmain = defaultMain"  simpleSetupHash :: String simpleSetupHash =     T.unpack $ decodeUtf8 $ S.take 8 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $-    encodeUtf8 (T.pack (unwords buildSetupArgs)) <> setupGhciShimCode <> simpleSetupCode+    toStrictBytes $+    Data.ByteString.Builder.toLazyByteString $+    encodeUtf8Builder (T.pack (unwords buildSetupArgs)) <> setupGhciShimCode <> simpleSetupCode  -- | Get a compiled Setup exe getSetupExe :: HasEnvConfig env@@ -274,7 +272,7 @@             baseNameS ++ ".jsexe"         setupDir =             view stackRootL config </>-            $(mkRelDir "setup-exe-cache") </>+            relDirSetupExeCache </>             platformDir      exePath <- (setupDir </>) <$> parseRelFile exeNameS@@ -298,11 +296,11 @@                     , toFilePath tmpOutputPath                     ] ++                     ["-build-runner" | wc == Ghcjs]-            withWorkingDir (toFilePath tmpdir) (proc (compilerExeName wc) args $ \pc0 -> do+            compilerPath <- getCompilerPath+            withWorkingDir (toFilePath tmpdir) (proc (toFilePath compilerPath) args $ \pc0 -> do               let pc = setStdout (useHandleOpen stderr) pc0               runProcess_ pc)-                `catch` \ece -> do-                    compilerPath <- getCompilerPath wc+                `catch` \ece ->                     throwM $ SetupHsBuildFailure (eceExitCode ece) Nothing compilerPath args Nothing []             when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath             renameFile tmpExePath exePath@@ -314,44 +312,43 @@                -> BuildOptsCLI                -> BaseConfigOpts                -> [LocalPackage]-               -> [DumpPackage () () ()] -- ^ global packages-               -> [DumpPackage () () ()] -- ^ snapshot packages-               -> [DumpPackage () () ()] -- ^ local packages+               -> [DumpPackage] -- ^ global packages+               -> [DumpPackage] -- ^ snapshot packages+               -> [DumpPackage] -- ^ local packages+               -> Maybe Int -- ^ largest package name, for nicer interleaved output                -> (ExecuteEnv -> RIO env a)                -> RIO env a-withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner =+withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages mlargestPackageName inner =     createTempDirFunction stackProgName $ \tmpdir -> do         configLock <- liftIO $ newMVar ()         installLock <- liftIO $ newMVar ()         idMap <- liftIO $ newTVarIO Map.empty         config <- view configL -        getGhcPath <- runOnce $ getCompilerPath Ghc-        getGhcjsPath <- runOnce $ getCompilerPath Ghcjs         customBuiltRef <- newIORef Set.empty          -- Create files for simple setup and setup shim, if necessary         let setupSrcDir =                 view stackRootL config </>-                $(mkRelDir "setup-exe-src")+                relDirSetupExeSrc         ensureDir setupSrcDir         setupFileName <- parseRelFile ("setup-" ++ simpleSetupHash ++ ".hs")         let setupHs = setupSrcDir </> setupFileName         setupHsExists <- doesFileExist setupHs-        unless setupHsExists $ liftIO $ S.writeFile (toFilePath setupHs) simpleSetupCode+        unless setupHsExists $ writeBinaryFileAtomic setupHs simpleSetupCode         setupShimFileName <- parseRelFile ("setup-shim-" ++ simpleSetupHash ++ ".hs")         let setupShimHs = setupSrcDir </> setupShimFileName         setupShimHsExists <- doesFileExist setupShimHs-        unless setupShimHsExists $ liftIO $ S.writeFile (toFilePath setupShimHs) setupGhciShimCode+        unless setupShimHsExists $ writeBinaryFileAtomic setupShimHs setupGhciShimCode         setupExe <- getSetupExe setupHs setupShimHs tmpdir          cabalPkgVer <- view cabalVersionL-        globalDB <- getGlobalDB =<< view (actualCompilerVersionL.whichCompilerL)+        globalDB <- view $ compilerPathsL.to cpGlobalDB         snapshotPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages)         localPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages)         logFilesTChan <- liftIO $ atomically newTChan         let totalWanted = length $ filter lpWanted locals-        env <- ask+        pathEnvVar <- liftIO $ maybe mempty T.pack <$> lookupEnv "PATH"         inner ExecuteEnv             { eeBuildOpts = bopts             , eeBuildOptsCLI = boptsCli@@ -369,22 +366,21 @@             , eeSetupExe = setupExe             , eeCabalPkgVer = cabalPkgVer             , eeTotalWanted = totalWanted-            , eeWanted = wantedLocalPackages locals             , eeLocals = locals             , eeGlobalDB = globalDB             , eeGlobalDumpPkgs = toDumpPackagesByGhcPkgId globalPackages             , eeSnapshotDumpPkgs = snapshotPackagesTVar             , eeLocalDumpPkgs = localPackagesTVar             , eeLogFiles = logFilesTChan-            , eeGetGhcPath = runRIO env getGhcPath-            , eeGetGhcjsPath = runRIO env getGhcjsPath             , eeCustomBuilt = customBuiltRef+            , eeLargestPackageName = mlargestPackageName+            , eePathEnvVar = pathEnvVar             } `finally` dumpLogs logFilesTChan totalWanted   where     toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp))      createTempDirFunction-        | Just True <- boptsKeepTmpFiles bopts = withKeepSystemTempDir+        | boptsKeepTmpFiles bopts = withKeepSystemTempDir         | otherwise = withSystemTempDir      dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env ()@@ -436,6 +432,7 @@     isWarning :: Text -> Bool     isWarning t = ": Warning:" `T.isSuffixOf` t -- prior to GHC 8                || ": warning:" `T.isInfixOf` t -- GHC 8 is slightly different+               || "mwarning:" `T.isInfixOf` t -- colorized output      dumpLog :: String -> (Path Abs Dir, Path Abs File) -> RIO env ()     dumpLog msgSuffix (pkgDir, filepath) = do@@ -481,9 +478,9 @@             => BuildOptsCLI             -> BaseConfigOpts             -> [LocalPackage]-            -> [DumpPackage () () ()] -- ^ global packages-            -> [DumpPackage () () ()] -- ^ snapshot packages-            -> [DumpPackage () () ()] -- ^ local packages+            -> [DumpPackage] -- ^ global packages+            -> [DumpPackage] -- ^ snapshot packages+            -> [DumpPackage] -- ^ local packages             -> InstalledMap             -> Map PackageName Target             -> Plan@@ -491,7 +488,8 @@ executePlan boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do     logDebug "Executing the build plan"     bopts <- view buildOptsL-    withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap targets plan)+    withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages mlargestPackageName+      (executePlan' installedMap targets plan)      copyExecutables (planInstallExes plan) @@ -506,6 +504,11 @@     withProcessContext menv' $       forM_ (boptsCLIExec boptsCli) $ \(cmd, args) ->       proc cmd args runProcess_+  where+    mlargestPackageName =+      Set.lookupMax $+      Set.map (length . packageNameString) $+      Map.keysSet (planTasks plan) <> Map.keysSet (planFinals plan)  copyExecutables     :: HasEnvConfig env@@ -591,19 +594,11 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do     when (toCoverage $ boptsTestOpts eeBuildOpts) deleteHpcReports     cv <- view actualCompilerVersionL-    let wc = view whichCompilerL cv-    case Map.toList $ planUnregisterLocal plan of-        [] -> return ()-        ids -> do+    case nonEmpty . Map.toList $ planUnregisterLocal plan of+        Nothing -> return ()+        Just ids -> do             localDB <- packageDatabaseLocal-            forM_ ids $ \(id', (ident, reason)) -> do-                logInfo $-                    RIO.display ident <>-                    ": unregistering" <>-                    if T.null reason-                        then ""-                        else " (" <> RIO.display reason <> ")"-                unregisterGhcPkgId wc cv localDB id' ident+            unregisterPackages cv localDB ids      liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap ->         foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan)@@ -632,9 +627,10 @@                     run $ logStickyDone ("Completed " <> RIO.display total <> " action(s).")                 | otherwise = do                     inProgress <- readTVarIO actionsVar-                    let packageNames = map (\(ActionId pkgID _) -> packageIdentifierText pkgID) (toList inProgress)+                    let packageNames = map (\(ActionId pkgID _) -> pkgName pkgID) (toList inProgress)+                        nowBuilding :: [PackageName] -> Utf8Builder                         nowBuilding []    = ""-                        nowBuilding names = mconcat $ ": " : intersperse ", " (map RIO.display names)+                        nowBuilding names = mconcat $ ": " : intersperse ", " (map (fromString . packageNameString) names)                     when terminal $ run $                         logSticky $                             "Progress " <> RIO.display prev <> "/" <> RIO.display total <>@@ -652,9 +648,9 @@     when (boptsHaddock eeBuildOpts) $ do         snapshotDumpPkgs <- liftIO (readTVarIO eeSnapshotDumpPkgs)         localDumpPkgs <- liftIO (readTVarIO eeLocalDumpPkgs)-        generateLocalHaddockIndex wc eeBaseConfigOpts localDumpPkgs eeLocals-        generateDepsHaddockIndex wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals-        generateSnapHaddockIndex wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs+        generateLocalHaddockIndex eeBaseConfigOpts localDumpPkgs eeLocals+        generateDepsHaddockIndex eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals+        generateSnapHaddockIndex eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs         when (boptsOpenHaddocks eeBuildOpts) $ do             let planPkgs, localPkgs, installedPkgs, availablePkgs                     :: Map PackageName (PackageIdentifier, InstallLocation)@@ -668,10 +664,54 @@   where     installedMap' = Map.difference installedMap0                   $ Map.fromList-                  $ map (\(ident, _) -> (packageIdentifierName ident, ()))+                  $ map (\(ident, _) -> (pkgName ident, ()))                   $ Map.elems                   $ planUnregisterLocal plan +unregisterPackages ::+       (HasProcessContext env, HasLogFunc env, HasPlatform env, HasCompiler env)+    => ActualCompiler+    -> Path Abs Dir+    -> NonEmpty (GhcPkgId, (PackageIdentifier, Text))+    -> RIO env ()+unregisterPackages cv localDB ids = do+    let logReason ident reason =+            logInfo $+            fromString (packageIdentifierString ident) <> ": unregistering" <>+            if T.null reason+                then ""+                else " (" <> RIO.display reason <> ")"+    let unregisterSinglePkg select (gid, (ident, reason)) = do+            logReason ident reason+            pkg <- getGhcPkgExe+            unregisterGhcPkgIds pkg localDB $ select ident gid :| []++    case cv of+        -- GHC versions >= 8.0.1 support batch unregistering of packages. See+        -- https://github.com/commercialhaskell/stack/pull/4554+        ACGhc v | v >= mkVersion [8, 0, 1] -> do+                platform <- view platformL+                -- According to https://support.microsoft.com/en-us/help/830473/command-prompt-cmd-exe-command-line-string-limitation+                -- the maximum command line length on Windows since XP is 8191 characters.+                -- We use conservative batch size of 100 ids on this OS thus argument name '-ipid', package name,+                -- its version and a hash should fit well into this limit.+                -- On Unix-like systems we're limited by ARG_MAX which is normally hundreds+                -- of kilobytes so batch size of 500 should work fine.+                let batchSize = case platform of+                      Platform _ Windows -> 100+                      _ -> 500+                let chunksOfNE size = mapMaybe nonEmpty . chunksOf size . NonEmpty.toList+                for_ (chunksOfNE batchSize ids) $ \batch -> do+                    for_ batch $ \(_, (ident, reason)) -> logReason ident reason+                    pkg <- getGhcPkgExe+                    unregisterGhcPkgIds pkg localDB $ fmap (Right . fst) batch++        -- GHC versions >= 7.9 support unregistering of packages via their+        -- GhcPkgId.+        ACGhc v | v >= mkVersion [7, 9] -> for_ ids . unregisterSinglePkg $ \_ident gid -> Right gid++        _ -> for_ ids . unregisterSinglePkg $ \ident _gid -> Left ident+ toActions :: HasEnvConfig env           => InstalledMap           -> Maybe (MVar ())@@ -752,7 +792,6 @@                => ExecuteEnv -> Task -> InstalledMap -> Bool -> Bool                -> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache) getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBench = do-    useExactConf <- view $ configL.to configAllowNewer     let extra =             -- We enable tests if the test suite dependencies are already             -- installed, so that we avoid unnecessary recompilation based on@@ -760,13 +799,13 @@             -- 'stack test'. See:             -- https://github.com/commercialhaskell/stack/issues/805             case taskType of-                TTFiles lp _ ->+                TTLocalMutable _ ->                   -- 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))]-                _ -> []+                  [ "--enable-tests" | enableTest] +++                  [ "--enable-benchmarks" | enableBench]+                TTRemotePackage{} -> []     idMap <- liftIO $ readTVarIO eeGhcPkgIds     let getMissing ident =             case Map.lookup ident idMap of@@ -774,10 +813,10 @@                     -- Expect to instead find it in installedMap if it's                     -- an initialBuildSteps target.                     | boptsCLIInitialBuildSteps eeBuildOptsCLI && taskIsTarget task,-                      Just (_, installed) <- Map.lookup (packageIdentifierName ident) installedMap+                      Just (_, installed) <- Map.lookup (pkgName ident) installedMap                         -> installedToGhcPkgId ident installed                 Just installed -> installedToGhcPkgId ident installed-                _ -> error "singleBuild: invariant violated, missing package ID missing"+                _ -> error $ "singleBuild: invariant violated, missing package ID missing: " ++ show ident         installedToGhcPkgId ident (Library ident' x _) = assert (ident == ident') $ Just (ident, x)         installedToGhcPkgId _ (Executable _) = Nothing         missing' = Map.fromList $ mapMaybe getMissing $ Set.toList missing@@ -791,11 +830,11 @@             , configCacheDeps = allDeps             , configCacheComponents =                 case taskType of-                    TTFiles lp _ -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp-                    TTIndex{} -> Set.empty-            , configCacheHaddock =-                shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides)+                    TTLocalMutable lp -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp+                    TTRemotePackage{} -> Set.empty+            , configCacheHaddock = taskBuildHaddock             , configCachePkgSrc = taskCachePkgSrc+            , configCachePathEnvVar = eePathEnvVar             }         allDepsMap = Map.union missing' taskPresent     return (allDepsMap, cache)@@ -811,9 +850,11 @@              -> Task              -> RIO env Bool ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task = do-    newCabalMod <- liftIO (fmap modTime (D.getModificationTime (toFilePath cabalfp)))+    newCabalMod <- liftIO $ modificationTime <$> getFileStatus (toFilePath cabalfp)+    -- See https://github.com/commercialhaskell/stack/issues/3554+    taskAnyMissingHack <- view $ actualCompilerVersionL.to getGhcVersion.to (< mkVersion [8, 4])     needConfig <--        if boptsReconfigure eeBuildOpts || taskAnyMissing task+        if boptsReconfigure eeBuildOpts || (taskAnyMissing task && taskAnyMissingHack)             then return True             else do                 -- We can ignore the components portion of the config@@ -837,10 +878,15 @@     when needConfig $ withMVar eeConfigureLock $ \_ -> do         deleteCaches pkgDir         announce+        cp <- view compilerPathsL+        let (GhcPkgExe pkgPath) = cpPkg cp         let programNames =-                if eeCabalPkgVer < $(mkVersion "1.22")-                    then ["ghc", "ghc-pkg"]-                    else ["ghc", "ghc-pkg", "ghcjs", "ghcjs-pkg"]+              case cpWhich cp of+                Ghc ->+                  [ "--with-ghc=" ++ toFilePath (cpCompiler cp)+                  , "--with-ghc-pkg=" ++ toFilePath pkgPath+                  ]+                Ghcjs -> []         exes <- forM programNames $ \name -> do             mpath <- findExecutable name             return $ case mpath of@@ -853,7 +899,11 @@             , dirs             , nodirs             ]-        writeConfigCache pkgDir newConfigCache+        -- Only write the cache for local packages.  Remote packages are built+        -- in a temporary directory so the cache would never be used anyway.+        case taskType task of+            TTLocalMutable{} -> writeConfigCache pkgDir newConfigCache+            TTRemotePackage{} -> return ()         writeCabalMod pkgDir newCabalMod      return needConfig@@ -863,24 +913,101 @@     -- with autoreconf -i. See:     -- https://github.com/commercialhaskell/stack/issues/3534     ensureConfigureScript = do-      let fp = pkgDir </> $(mkRelFile "configure")+      let fp = pkgDir </> relFileConfigure       exists <- doesFileExist fp       unless exists $ do         logInfo $ "Trying to generate configure with autoreconf in " <> fromString (toFilePath pkgDir)-        withWorkingDir (toFilePath pkgDir) $ readProcessNull "autoreconf" ["-i"] `catchAny` \ex ->+        let autoreconf = if osIsWindows+                           then readProcessNull "sh" ["autoreconf", "-i"]+                           else readProcessNull "autoreconf" ["-i"]+            -- On Windows 10, an upstream issue with the `sh autoreconf -i`+            -- command means that command clears, but does not then restore, the+            -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. The+            -- folowing hack re-enables the lost ANSI-capability.+            fixupOnWindows = when osIsWindows (void $ liftIO defaultColorWhen)+        withWorkingDir (toFilePath pkgDir) $ autoreconf `catchAny` \ex -> do+          fixupOnWindows           logWarn $ "Unable to run autoreconf: " <> displayShow ex+          when osIsWindows $ do+            logInfo $ "Check that executable perl is on the path in stack's " <>+              "MSYS2 \\usr\\bin folder, and working, and that script file " <>+              "autoreconf is on the path in that location. To check that " <>+              "perl or autoreconf are on the path in the required location, " <>+              "run commands:"+            logInfo ""+            logInfo "  stack exec where -- perl"+            logInfo "  stack exec where -- autoreconf"+            logInfo ""+            logInfo $ "If perl or autoreconf is not on the path in the " <>+              "required location, add them with command (note that the " <>+              "relevant package name is 'autoconf' not 'autoreconf'):"+            logInfo ""+            logInfo "  stack exec pacman -- --sync --refresh autoconf"+            logInfo ""+            logInfo $ "Some versions of perl from MYSY2 are broken. See " <>+              "https://github.com/msys2/MSYS2-packages/issues/1611 and " <>+              "https://github.com/commercialhaskell/stack/pull/4781. To " <>+              "test if perl in the required location is working, try command:"+            logInfo ""+            logInfo "  stack exec perl -- --version"+            logInfo ""+        fixupOnWindows -announceTask :: HasLogFunc env => Task -> Text -> RIO env ()-announceTask task x = logInfo $-    RIO.display (taskProvides task) <>-    ": " <>-    RIO.display x+-- | Make a padded prefix for log messages+packageNamePrefix :: ExecuteEnv -> PackageName -> Utf8Builder+packageNamePrefix ee name' =+  let name = packageNameString name'+      paddedName =+        case eeLargestPackageName ee of+          Nothing -> name+          Just len -> assert (len >= length name) $ RIO.take len $ name ++ repeat ' '+   in fromString paddedName <> "> " +announceTask :: HasLogFunc env => ExecuteEnv -> Task -> Utf8Builder -> RIO env ()+announceTask ee task action = logInfo $+    packageNamePrefix ee (pkgName (taskProvides task)) <>+    action++-- | Ensure we're the only action using the directory.  See+-- <https://github.com/commercialhaskell/stack/issues/2730>+withLockedDistDir+  :: HasEnvConfig env+  => (Utf8Builder -> RIO env ()) -- ^ announce+  -> Path Abs Dir -- ^ root directory for package+  -> RIO env a+  -> RIO env a+withLockedDistDir announce root inner = do+  distDir <- distRelativeDir+  let lockFP = root </> distDir </> relFileBuildLock+  ensureDir $ parent lockFP++  mres <-+    withRunInIO $ \run ->+    withTryFileLock (toFilePath lockFP) Exclusive $ \_lock ->+    run inner++  case mres of+    Just res -> pure res+    Nothing -> do+      let complainer delay = do+            delay 5000000 -- 5 seconds+            announce $ "blocking for directory lock on " <> fromString (toFilePath lockFP)+            forever $ do+              delay 30000000 -- 30 seconds+              announce $ "still blocking for directory lock on " <>+                         fromString (toFilePath lockFP) <>+                         "; maybe another Stack process is running?"+      withCompanion complainer $+        \stopComplaining ->+        withRunInIO $ \run ->+        withFileLock (toFilePath lockFP) Exclusive $ \_ ->+        run $ stopComplaining *> inner+ -- | How we deal with output from GHC, either dumping to a log file or the -- console (with some prefix). data OutputType   = OTLogFile !(Path Abs File) !Handle-  | OTConsole !Utf8Builder+  | OTConsole !(Maybe Utf8Builder)  -- | This sets up a context for executing build steps which need to run -- Cabal (via a compiled Setup.hs).  In particular it does the following:@@ -905,24 +1032,26 @@                   -> (  Package                                -- Package info                      -> Path Abs File                          -- Cabal file path                      -> Path Abs Dir                           -- Package root directory file path-                     -> (ExcludeTHLoading -> [String] -> RIO env ())+                     -- Note that the `Path Abs Dir` argument is redundant with the `Path Abs File`+                     -- argument, but we provide both to avoid recalculating `parent` of the `File`.+                     -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())                                                                -- Function to run Cabal with args-                     -> (Text -> RIO env ())             -- An 'announce' function, for different build phases+                     -> (Utf8Builder -> RIO env ())      -- An 'announce' function, for different build phases                      -> OutputType                      -> RIO env a)                   -> RIO env a-withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 =+withSingleContext ActionContext {..} ee@ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 =     withPackage $ \package cabalfp pkgDir ->     withOutputType pkgDir package $ \outputType ->     withCabal package pkgDir outputType $ \cabal ->     inner0 package cabalfp pkgDir cabal announce outputType   where-    announce = announceTask task+    announce = announceTask ee task      wanted =         case taskType of-            TTFiles lp _ -> lpWanted lp-            TTIndex{} -> False+            TTLocalMutable lp -> lpWanted lp+            TTRemotePackage{} -> False      -- Output to the console if this is the last task, and the user     -- asked to build it specifically. When the action is a@@ -940,25 +1069,44 @@      withPackage inner =         case taskType of-            TTFiles lp _ -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp)-            TTIndex package _ pir -> do-                mdist <- distRelativeDir-                dir <- unpackPackageIdent eeTempDir mdist pir+            TTLocalMutable lp -> do+              let root = parent $ lpCabalFile lp+              withLockedDistDir announce root $+                inner (lpPackage lp) (lpCabalFile lp) root+            TTRemotePackage _ package pkgloc -> do+                suffix <- parseRelDir $ packageIdentifierString $ packageIdent package+                let dir = eeTempDir </> suffix+                unpackPackageLocation dir pkgloc -                let name = packageIdentifierName taskProvides+                -- See: https://github.com/fpco/stack/issues/157+                distDir <- distRelativeDir+                let oldDist = dir </> relDirDist+                    newDist = dir </> distDir+                exists <- doesDirExist oldDist+                when exists $ do+                  -- Previously used takeDirectory, but that got confused+                  -- by trailing slashes, see:+                  -- https://github.com/commercialhaskell/stack/issues/216+                  --+                  -- Instead, use Path which is a bit more resilient+                  ensureDir $ parent newDist+                  renameDir oldDist newDist++                let name = pkgName taskProvides                 cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal"                 let cabalfp = dir </> cabalfpRel                 inner package cabalfp dir      withOutputType pkgDir package inner-        -- If the user requested interleaved output, dump to the console with a-        -- prefix.-        | boptsInterleavedOutput eeBuildOpts = inner $ OTConsole $ RIO.display (packageName package) <> "> "-         -- Not in interleaved mode. When building a single wanted package, dump         -- to the console with no prefix.-        | console = inner $ OTConsole mempty+        | console = inner $ OTConsole Nothing +        -- If the user requested interleaved output, dump to the console with a+        -- prefix.+        | boptsInterleavedOutput eeBuildOpts =+             inner $ OTConsole $ Just $ packageNamePrefix ee $ packageName package+         -- Neither condition applies, dump to a file.         | otherwise = do             logPath <- buildLogPath package msuffix@@ -967,7 +1115,7 @@              -- We only want to dump logs for local non-dependency packages             case taskType of-                TTFiles lp _ | lpWanted lp ->+                TTLocalMutable lp | lpWanted lp ->                     liftIO $ atomically $ writeTChan eeLogFiles (pkgDir, logPath)                 _ -> return () @@ -977,14 +1125,12 @@         :: Package         -> Path Abs Dir         -> OutputType-        -> ((ExcludeTHLoading -> [String] -> RIO env ()) -> RIO env a)+        -> ((KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()) -> RIO env a)         -> RIO env a     withCabal package pkgDir outputType inner = do         config <- view configL-         unless (configAllowDifferentUser config) $             checkOwnership (pkgDir </> configWorkDir config)-         let envSettings = EnvSettings                 { esIncludeLocals = taskLocation task == Local                 , esIncludeGhcPackagePath = False@@ -1001,12 +1147,12 @@             case (packageBuildType package, eeSetupExe) of                 (C.Simple, Just setupExe) -> return $ Left setupExe                 _ -> liftIO $ Right <$> getSetupHs pkgDir-        inner $ \stripTHLoading args -> do+        inner $ \keepOutputOpen stripTHLoading args -> do             let cabalPackageArg                     -- Omit cabal package dependency when building                     -- Cabal. See                     -- https://github.com/commercialhaskell/stack/issues/1356-                    | packageName package == $(mkPackageName "Cabal") = []+                    | packageName package == mkPackageName "Cabal" = []                     | otherwise =                         ["-package=" ++ packageIdentifierString                                             (PackageIdentifier cabalPackageName@@ -1024,10 +1170,10 @@                 warnCustomNoDeps :: RIO env ()                 warnCustomNoDeps =                     case (taskType, packageBuildType package) of-                        (TTFiles lp Local, C.Custom) | lpWanted lp -> do+                        (TTLocalMutable lp, C.Custom) | lpWanted lp -> do                             prettyWarnL                                 [ flow "Package"-                                , display $ packageName package+                                , fromString $ packageNameString $ packageName package                                 , flow "uses a custom Cabal build, but does not use a custom-setup stanza"                                 ]                         _ -> return ()@@ -1041,9 +1187,9 @@                         -- explicit list of dependencies, and we                         -- should simply use all of them.                         (Just customSetupDeps, _) -> do-                            unless (Map.member $(mkPackageName "Cabal") customSetupDeps) $+                            unless (Map.member (mkPackageName "Cabal") customSetupDeps) $                                 prettyWarnL-                                    [ display $ packageName package+                                    [ fromString $ packageNameString $ packageName package                                     , "has a setup-depends field, but it does not mention a Cabal dependency. This is likely to cause build errors."                                     ]                             allDeps <-@@ -1059,17 +1205,17 @@                                 case filter (matches . fst) (Map.toList allDeps) of                                     x:xs -> do                                         unless (null xs)-                                            (logWarn ("Found multiple installed packages for custom-setup dep: " <> RIO.display name))-                                        return ("-package-id=" ++ ghcPkgIdString (snd x), Just (toCabalPackageIdentifier (fst x)))+                                            (logWarn ("Found multiple installed packages for custom-setup dep: " <> fromString (packageNameString name)))+                                        return ("-package-id=" ++ ghcPkgIdString (snd x), Just (fst x))                                     [] -> do-                                        logWarn ("Could not find custom-setup dep: " <> RIO.display name)+                                        logWarn ("Could not find custom-setup dep: " <> fromString (packageNameString name))                                         return ("-package=" ++ packageNameString name, Nothing)                             let depsArgs = map fst matchedDeps                             -- Generate setup_macros.h and provide it to ghc                             let macroDeps = mapMaybe snd matchedDeps-                                cppMacrosFile = toFilePath $ setupDir </> $(mkRelFile "setup_macros.h")-                                cppArgs = ["-optP-include", "-optP" ++ cppMacrosFile]-                            liftIO $ S.writeFile cppMacrosFile (encodeUtf8 (T.pack (C.generatePackageVersionMacros macroDeps)))+                                cppMacrosFile = setupDir </> relFileSetupMacrosH+                                cppArgs = ["-optP-include", "-optP" ++ toFilePath cppMacrosFile]+                            writeBinaryFileAtomic cppMacrosFile (encodeUtf8Builder (T.pack (C.generatePackageVersionMacros macroDeps)))                             return (packageDBArgs ++ depsArgs ++ cppArgs)                          -- This branch is taken when@@ -1125,14 +1271,17 @@                         (mlogFile, bss) <-                             case outputType of                                 OTConsole _ -> return (Nothing, [])-                                OTLogFile logFile h -> do-                                    liftIO $ hClose h-                                    fmap (Just logFile,) $ withSourceFile (toFilePath logFile) $ \src ->-                                           runConduit-                                         $ src-                                        .| CT.decodeUtf8Lenient-                                        .| mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer-                                        .| CL.consume+                                OTLogFile logFile h ->+                                    if keepOutputOpen == KeepOpen+                                    then return (Nothing, []) -- expected failure build continues further+                                    else do+                                        liftIO $ hClose h+                                        fmap (Just logFile,) $ withSourceFile (toFilePath logFile) $ \src ->+                                               runConduit+                                             $ src+                                            .| CT.decodeUtf8Lenient+                                            .| mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer+                                            .| CL.consume                         throwM $ CabalExitedUnsuccessfully                             (eceExitCode ece)                             taskProvides@@ -1141,15 +1290,19 @@                             mlogFile                             bss                   where-                    runAndOutput :: CompilerVersion 'CVActual -> RIO env ()+                    runAndOutput :: ActualCompiler -> RIO env ()                     runAndOutput compilerVer = withWorkingDir (toFilePath pkgDir) $ withProcessContext menv $ case outputType of                         OTLogFile _ h ->                             proc (toFilePath exeName) fullArgs                           $ runProcess_+                            -- Don't use closed, since that can break+                            -- ./configure scripts. See:+                            -- https://github.com/commercialhaskell/stack/pull/4722                           . setStdin (byteStringInput "")                           . setStdout (useHandleOpen h)                           . setStderr (useHandleOpen h)-                        OTConsole prefix ->+                        OTConsole mprefix ->+                            let prefix = fold mprefix in                             void $ sinkProcessStderrStdout (toFilePath exeName) fullArgs                                 (outputSink KeepTHLoading LevelWarn compilerVer prefix)                                 (outputSink stripTHLoading LevelInfo compilerVer prefix)@@ -1157,7 +1310,7 @@                         :: HasCallStack                         => ExcludeTHLoading                         -> LogLevel-                        -> CompilerVersion 'CVActual+                        -> ActualCompiler                         -> Utf8Builder                         -> ConduitM S.ByteString Void (RIO env) ()                     outputSink excludeTH level compilerVer prefix =@@ -1174,18 +1327,15 @@                 Left setupExe -> return setupExe                 Right setuphs -> do                     distDir <- distDirFromDir pkgDir-                    let setupDir = distDir </> $(mkRelDir "setup")-                        outputFile = setupDir </> $(mkRelFile "setup")+                    let setupDir = distDir </> relDirSetup+                        outputFile = setupDir </> relFileSetupLower                     customBuilt <- liftIO $ readIORef eeCustomBuilt                     if Set.member (packageName package) customBuilt                         then return outputFile                         else do                             ensureDir setupDir                             compiler <- view $ actualCompilerVersionL.whichCompilerL-                            compilerPath <--                                case compiler of-                                    Ghc -> eeGetGhcPath-                                    Ghcjs -> eeGetGhcjsPath+                            compilerPath <- view $ compilerPathsL.to cpCompiler                             packageArgs <- getPackageArgs setupDir                             runExe compilerPath $                                 [ "--make"@@ -1202,7 +1352,17 @@                                 ] ++                                 (case compiler of                                     Ghc -> []-                                    Ghcjs -> ["-build-runner"])+                                    Ghcjs -> ["-build-runner"]) ++++                                -- Apply GHC options+                                -- https://github.com/commercialhaskell/stack/issues/4526+                                map T.unpack (+                                  Map.findWithDefault [] AGOEverything (configGhcOptionsByCat config) +++                                  case configApplyGhcOptions config of+                                    AGOEverything -> boptsCLIGhcOptions eeBuildOptsCLI+                                    AGOTargets -> []+                                    AGOLocals -> [])+                             liftIO $ atomicModifyIORef' eeCustomBuilt $                                 \oldCustomBuilt -> (Set.insert (packageName package) oldCustomBuilt, ())                             return outputFile@@ -1220,7 +1380,7 @@ -- -- * Generates haddocks ----- * Registers the library and copiesthe built executables into the+-- * Registers the library and copies the built executables into the --   local install directory. Note that this is literally invoking Cabal --   with @copy@, and not the copying done by @stack install@ - that is --   handled by 'copyExecutables'.@@ -1237,20 +1397,33 @@     minstalled <-         case mprecompiled of             Just precompiled -> copyPreCompiled precompiled-            Nothing -> realConfigAndBuild cache allDepsMap+            Nothing -> do+                mcurator <- view $ buildConfigL.to bcCurator+                realConfigAndBuild cache mcurator allDepsMap     case minstalled of         Nothing -> return ()         Just installed -> do             writeFlagCache installed cache             liftIO $ atomically $ modifyTVar eeGhcPkgIds $ Map.insert taskProvides installed   where-    pname = packageIdentifierName taskProvides-    shouldHaddockPackage' = shouldHaddockPackage eeBuildOpts eeWanted pname-    doHaddock package = shouldHaddockPackage' &&+    pname = pkgName taskProvides+    doHaddock mcurator package+                      = taskBuildHaddock &&                         not isFinalBuild &&                         -- Works around haddock failing on bytestring-builder since it has no modules                         -- when bytestring is new enough.-                        packageHasExposedModules package+                        packageHasExposedModules package &&+                        -- Special help for the curator tool to avoid haddocks that are known to fail+                        maybe True (Set.notMember pname . curatorSkipHaddock) mcurator+    expectHaddockFailure mcurator =+        maybe False (Set.member pname . curatorExpectHaddockFailure) mcurator+    fulfillHaddockExpectations mcurator action | expectHaddockFailure mcurator = do+        eres <- tryAny $ action KeepOpen+        case eres of+          Right () -> logWarn $ fromString (packageNameString pname) <> ": unexpected Haddock success"+          Left _ -> return ()+    fulfillHaddockExpectations _ action = do+        action CloseOnException      buildingFinals = isFinalBuild || taskAllInOne     enableTests = buildingFinals && any isCTest (taskComponents task)@@ -1266,7 +1439,7 @@             , ["bench" | enableBenchmarks]             ]         (hasLib, hasSubLib, hasExe) = case taskType of-            TTFiles lp Local ->+            TTLocalMutable lp ->               let package = lpPackage lp                   hasLibrary =                     case packageLibraries package of@@ -1280,22 +1453,20 @@             _ -> (False, False, False)      getPrecompiled cache =-        case taskLocation task of-            Snap | not shouldHaddockPackage' -> do-                mpc <--                  case taskLocation task of-                    Snap -> readPrecompiledCache-                      (ttPackageLocation taskType)-                      (configCacheOpts cache)-                      (configCacheDeps cache)-                    _ -> return Nothing+        case taskType of+            TTRemotePackage Immutable _ loc -> do+                mpc <- readPrecompiledCache+                       loc+                       (configCacheOpts cache)+                       (configCacheHaddock cache)+                       (configCacheDeps cache)                 case mpc of                     Nothing -> return Nothing                     -- Only pay attention to precompiled caches that refer to packages within                     -- the snapshot.                     Just pc | maybe False                                     (bcoSnapInstallRoot eeBaseConfigOpts `isProperPrefixOf`)-                                    (parseAbsFile =<< pcLibrary pc) ->+                                    (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@@ -1306,22 +1477,22 @@                             allM f (x:xs) = do                                 b <- f x                                 if b then allM f xs else return False-                        b <- liftIO $ allM D.doesFileExist $ maybe id (:) (pcLibrary pc) $ pcExes pc+                        b <- liftIO $ allM doesFileExist $ maybe id (:) (pcLibrary pc) $ pcExes pc                         return $ if b then Just pc else Nothing             _ -> return Nothing      copyPreCompiled (PrecompiledCache mlib sublibs exes) = do         wc <- view $ actualCompilerVersionL.whichCompilerL-        announceTask task "using precompiled package"+        announceTask ee task "using precompiled package"          -- We need to copy .conf files for the main library and all sublibraries which exist in the cache,         -- from their old snapshot to the new one. However, we must unregister any such library in the new         -- snapshot, in case it was built with different flags.         let           subLibNames = map T.unpack . Set.toList $ case taskType of-            TTFiles lp _ -> packageInternalLibraries $ lpPackage lp-            TTIndex p _ _ -> packageInternalLibraries p-          (name, version) = toTuple taskProvides+            TTLocalMutable lp -> packageInternalLibraries $ lpPackage lp+            TTRemotePackage _ p _ -> packageInternalLibraries p+          PackageIdentifier name version = taskProvides           mainLibName = packageNameString name           mainLibVersion = versionString version           pkgName = mainLibName ++ "-" ++ mainLibVersion@@ -1342,21 +1513,21 @@                       (T.pack $ toFilePathNoTrailingSep $ bcoSnapDB eeBaseConfigOpts)                  withModifyEnvVars modifyEnv $ do-                  let ghcPkgExe = ghcPkgExeName wc+                  GhcPkgExe ghcPkgExe <- getGhcPkgExe                    -- first unregister everything that needs to be unregistered                   forM_ allToUnregister $ \packageName -> catchAny-                      (readProcessNull ghcPkgExe [ "unregister", "--force", packageName])+                      (readProcessNull (toFilePath ghcPkgExe) [ "unregister", "--force", packageName])                       (const (return ()))                    -- now, register the cached conf files                   forM_ allToRegister $ \libpath ->-                    proc ghcPkgExe [ "register", "--force", libpath] readProcess_+                    proc (toFilePath ghcPkgExe) [ "register", "--force", toFilePath libpath] readProcess_          liftIO $ forM_ exes $ \exe -> do-            D.createDirectoryIfMissing True bindir-            let dst = bindir FP.</> FP.takeFileName exe-            createLink exe dst `catchIO` \_ -> D.copyFile exe dst+            ensureDir bindir+            let dst = bindir </> filename exe+            createLink (toFilePath exe) (toFilePath dst) `catchIO` \_ -> copyFile exe dst         case (mlib, exes) of             (Nothing, _:_) -> markExeInstalled (taskLocation task) taskProvides             _ -> return ()@@ -1367,24 +1538,25 @@         case mlib of             Nothing -> return $ Just $ Executable taskProvides             Just _ -> do-                mpkgid <- loadInstalledPkg wc pkgDbs eeSnapshotDumpPkgs pname+                mpkgid <- loadInstalledPkg pkgDbs eeSnapshotDumpPkgs pname                  return $ Just $                     case mpkgid of                         Nothing -> assert False $ Executable taskProvides                         Just pkgid -> Library taskProvides pkgid Nothing       where-        bindir = toFilePath $ bcoSnapInstallRoot eeBaseConfigOpts </> bindirSuffix+        bindir = bcoSnapInstallRoot eeBaseConfigOpts </> bindirSuffix -    realConfigAndBuild cache allDepsMap = withSingleContext ac ee task (Just allDepsMap) Nothing-        $ \package cabalfp pkgDir cabal announce _outputType -> do+    realConfigAndBuild cache mcurator allDepsMap = withSingleContext ac ee task (Just allDepsMap) Nothing+        $ \package cabalfp pkgDir cabal0 announce _outputType -> do+            let cabal = cabal0 CloseOnException             executableBuildStatuses <- getExecutableBuildStatuses package pkgDir             when (not (cabalIsSatisfied executableBuildStatuses) && taskIsTarget task)                  (logInfo-                      ("Building all executables for `" <> RIO.display (packageName package) <>+                      ("Building all executables for `" <> fromString (packageNameString (packageName package)) <>                        "' once. After a successful build of all of them, only specified executables will be rebuilt.")) -            _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix executableBuildStatuses)) cabal cabalfp task+            _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> RIO.display (annSuffix executableBuildStatuses))) cabal cabalfp task              let installedMapHasThisPkg :: Bool                 installedMapHasThisPkg =@@ -1403,37 +1575,40 @@                 (_, True) | null acDownstream || installedMapHasThisPkg -> do                     initialBuildSteps executableBuildStatuses cabal announce                     return Nothing-                _ -> liftM Just $ realBuild cache package pkgDir cabal announce executableBuildStatuses+                _ -> fulfillCuratorBuildExpectations pname mcurator enableTests enableBenchmarks Nothing $+                     Just <$> realBuild cache package pkgDir cabal0 announce executableBuildStatuses      initialBuildSteps executableBuildStatuses cabal announce = do-        () <- announce ("initial-build-steps" <> annSuffix executableBuildStatuses)+        announce ("initial-build-steps" <> RIO.display (annSuffix executableBuildStatuses))         cabal KeepTHLoading ["repl", "stack-initial-build-steps"]      realBuild         :: ConfigCache         -> Package         -> Path Abs Dir-        -> (ExcludeTHLoading -> [String] -> RIO env ())-        -> (Text -> RIO env ())+        -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())+        -> (Utf8Builder -> RIO env ())         -> Map Text ExecutableBuildStatus         -> RIO env Installed-    realBuild cache package pkgDir cabal announce executableBuildStatuses = do+    realBuild cache package pkgDir cabal0 announce executableBuildStatuses = do+        let cabal = cabal0 CloseOnException         wc <- view $ actualCompilerVersionL.whichCompilerL          markExeNotInstalled (taskLocation task) taskProvides         case taskType of-            TTFiles lp _ -> do -- FIXME should this only be for local packages?+            TTLocalMutable lp -> do                 when enableTests $ unsetTestSuccess pkgDir+                caches <- runMemoizedWith $ lpNewBuildCaches lp                 mapM_ (uncurry (writeBuildCache pkgDir))-                      (Map.toList $ lpNewBuildCaches lp)-            TTIndex{} -> return ()+                      (Map.toList caches)+            TTRemotePackage{} -> return ()          -- FIXME: only output these if they're in the build plan. -        preBuildTime <- modTime <$> liftIO getCurrentTime+        preBuildTime <- liftIO epochTime         let postBuildCheck _succeeded = do                 mlocalWarnings <- case taskType of-                    TTFiles lp Local -> do+                    TTLocalMutable lp -> do                         warnings <- checkForUnlistedFiles taskType preBuildTime pkgDir                         -- TODO: Perhaps only emit these warnings for non extra-dep?                         return (Just (lpCabalFile lp, warnings))@@ -1446,16 +1621,16 @@                       "- In" <+>                       fromString (T.unpack (renderComponent comp)) <>                       ":" <> line <>-                      indent 4 (mconcat $ intersperse line $ map (styleGood . fromString . C.display) modules)+                      indent 4 (mconcat $ intersperse line $ map (style Good . 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 <>+                        pretty cabalfp <> ":" <> line <>                         indent 4 (mconcat $ intersperse line $ 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 executableBuildStatuses)+        () <- announce ("build" <> RIO.display (annSuffix executableBuildStatuses))         config <- view configL         extraOpts <- extraBuildOptions wc eeBuildOpts         let stripTHLoading@@ -1464,16 +1639,17 @@         cabal stripTHLoading (("build" :) $ (++ extraOpts) $             case (taskType, taskAllInOne, isFinalBuild) of                 (_, True, True) -> error "Invariant violated: cannot have an all-in-one build that also has a final build step."-                (TTFiles lp _, False, False) -> primaryComponentOptions executableBuildStatuses lp-                (TTFiles lp _, False, True) -> finalComponentOptions lp-                (TTFiles lp _, True, False) -> primaryComponentOptions executableBuildStatuses lp ++ finalComponentOptions lp-                (TTIndex{}, _, _) -> [])+                (TTLocalMutable lp, False, False) -> primaryComponentOptions executableBuildStatuses lp+                (TTLocalMutable lp, False, True) -> finalComponentOptions lp+                (TTLocalMutable lp, True, False) -> primaryComponentOptions executableBuildStatuses lp ++ finalComponentOptions lp+                (TTRemotePackage{}, _, _) -> [])           `catch` \ex -> case ex of               CabalExitedUnsuccessfully{} -> postBuildCheck False >> throwM ex               _ -> throwM ex         postBuildCheck True -        when (doHaddock package) $ do+        mcurator <- view $ buildConfigL.to bcCurator+        when (doHaddock mcurator package) $ do             announce "haddock"             sourceFlag <- if not (boptsHaddockHyperlinkSource eeBuildOpts) then return [] else do                 -- See #2429 for why the temp dir is used@@ -1501,11 +1677,11 @@             actualCompiler <- view actualCompilerVersionL             let quickjump =                   case actualCompiler of-                    GhcVersion ghcVer-                      | ghcVer >= $(mkVersion "8.4") -> ["--haddock-option=--quickjump"]+                    ACGhc ghcVer+                      | ghcVer >= mkVersion [8, 4] -> ["--haddock-option=--quickjump"]                     _ -> [] -            cabal KeepTHLoading $ concat+            fulfillHaddockExpectations mcurator $ \keep -> cabal0 keep KeepTHLoading $ concat                 [ ["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"]                 , sourceFlag                 , ["--internal" | boptsHaddockInternal eeBuildOpts]@@ -1531,6 +1707,28 @@                 _ -> return ()             when hasLibrary $ cabal KeepTHLoading ["register"] +        -- copy ddump-* files+        case T.unpack <$> boptsDdumpDir eeBuildOpts of+          Just ddumpPath | buildingFinals && not (null ddumpPath) -> do+            distDir <- distRelativeDir+            ddumpDir <- parseRelDir ddumpPath++            logDebug $ fromString ("ddump-dir: " <> toFilePath ddumpDir)+            logDebug $ fromString ("dist-dir: " <> toFilePath distDir)++            runConduitRes+              $ CF.sourceDirectoryDeep False (toFilePath distDir)+             .| CL.filter (isInfixOf ".dump-")+             .| CL.mapM_ (\src -> liftIO $ do+                  parentDir <- parent <$> parseRelDir src+                  destBaseDir <- (ddumpDir </>) <$> stripProperPrefix distDir parentDir+                  -- exclude .stack-work dir+                  unless (".stack-work" `isInfixOf` toFilePath destBaseDir) $ do+                    ensureDir destBaseDir+                    src' <- parseRelFile src+                    copyFile src' (destBaseDir </> filename src'))+          _ -> pure ()+         let (installedPkgDb, installedDumpPkgsTVar) =                 case taskLocation task of                     Snap ->@@ -1546,12 +1744,12 @@                 sublibsPkgIds <- fmap catMaybes $                   forM (Set.toList $ packageInternalLibraries package) $ \sublib -> do                     -- z-haddock-library-z-attoparsec for internal lib attoparsec of haddock-library-                    let sublibName = T.concat ["z-", packageNameText $ packageName package, "-z-", sublib]-                    case parsePackageName sublibName of+                    let sublibName = T.concat ["z-", T.pack $ packageNameString $ packageName package, "-z-", sublib]+                    case parsePackageName $ T.unpack sublibName of                       Nothing -> return Nothing -- invalid lib, ignored-                      Just subLibName -> loadInstalledPkg wc [installedPkgDb] installedDumpPkgsTVar subLibName+                      Just subLibName -> loadInstalledPkg [installedPkgDb] installedDumpPkgsTVar subLibName -                mpkgid <- loadInstalledPkg wc [installedPkgDb] installedDumpPkgsTVar (packageName package)+                mpkgid <- loadInstalledPkg [installedPkgDb] installedDumpPkgsTVar (packageName package)                 case mpkgid of                     Nothing -> throwM $ Couldn'tFindPkgId $ packageName package                     Just pkgid -> return (Library ident pkgid Nothing, sublibsPkgIds)@@ -1559,12 +1757,13 @@                 markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow with writeFlagCache?                 return (Executable ident, []) -- don't return sublibs in this case -        case taskLocation task of-            Snap ->+        case taskType of+            TTRemotePackage Immutable _ loc ->               writePrecompiledCache                 eeBaseConfigOpts-                (ttPackageLocation taskType)+                loc                 (configCacheOpts cache)+                (configCacheHaddock cache)                 (configCacheDeps cache)                 mpkgid sublibsPkgIds (packageExes package)             _ -> return ()@@ -1573,15 +1772,16 @@             -- For packages from a package index, pkgDir is in the tmp             -- directory. We eagerly delete it if no other tasks             -- require it, to reduce space usage in tmp (#3018).-            TTIndex{} -> do+            TTRemotePackage{} -> do                 let remaining = filter (\(ActionId x _) -> x == taskProvides) (Set.toList acRemaining)                 when (null remaining) $ removeDirRecur pkgDir-            _ -> return ()+            TTLocalMutable{} -> return ()          return mpkgid -    loadInstalledPkg wc pkgDbs tvar name = do-        dps <- ghcPkgDescribe name wc pkgDbs $ conduitDumpPackage .| CL.consume+    loadInstalledPkg pkgDbs tvar name = do+        pkgexe <- getGhcPkgExe+        dps <- ghcPkgDescribe pkgexe name pkgDbs $ conduitDumpPackage .| CL.consume         case dps of             [] -> return Nothing             [dp] -> do@@ -1616,7 +1816,7 @@     -> RIO env (Text, ExecutableBuildStatus) checkExeStatus compiler platform distDir name = do     exename <- parseRelDir (T.unpack name)-    exists <- checkPath (distDir </> $(mkRelDir "build") </> exename)+    exists <- checkPath (distDir </> relDirBuild </> exename)     pure         ( name         , if exists@@ -1640,30 +1840,22 @@         file = T.unpack name  -- | Check if any unlisted files have been found, and add them to the build cache.-checkForUnlistedFiles :: HasEnvConfig env => TaskType -> ModTime -> Path Abs Dir -> RIO env [PackageWarning]-checkForUnlistedFiles (TTFiles lp _) preBuildTime pkgDir = do+checkForUnlistedFiles :: HasEnvConfig env => TaskType -> CTime -> Path Abs Dir -> RIO env [PackageWarning]+checkForUnlistedFiles (TTLocalMutable lp) preBuildTime pkgDir = do+    caches <- runMemoizedWith $ lpNewBuildCaches lp     (addBuildCache,warnings) <-         addUnlistedToBuildCache             preBuildTime             (lpPackage lp)             (lpCabalFile lp)             (lpComponents lp)-            (lpNewBuildCaches lp)+            caches     forM_ (M.toList addBuildCache) $ \(component, newToCache) -> do-        let cache = Map.findWithDefault Map.empty component (lpNewBuildCaches lp)+        let cache = Map.findWithDefault Map.empty component caches         writeBuildCache pkgDir component $             Map.unions (cache : newToCache)     return warnings-checkForUnlistedFiles TTIndex{} _ _ = return []---- | Determine if all of the dependencies given are installed-depsPresent :: InstalledMap -> Map PackageName VersionRange -> Bool-depsPresent installedMap deps = all-    (\(name, range) ->-        case Map.lookup name installedMap of-            Just (_, installed) -> installedVersion installed `withinRange` range-            Nothing -> False)-    (Map.toList deps)+checkForUnlistedFiles TTRemotePackage{} _ _ = return []  -- | Implements running a package's tests. Also handles producing -- coverage reports if coverage is enabled.@@ -1679,6 +1871,9 @@     -- FIXME: Since this doesn't use cabal, we should be able to avoid using a     -- fullblown 'withSingleContext'.     (allDepsMap, _cache) <- getConfigCache ee task installedMap True False+    mcurator <- view $ buildConfigL.to bcCurator+    let pname = pkgName $ taskProvides task+        expectFailure = expectTestFailure pname mcurator     withSingleContext ac ee task (Just allDepsMap) (Just "test") $ \package _cabalfp pkgDir _cabal announce outputType -> do         config <- view configL         let needHpc = toCoverage topts@@ -1725,13 +1920,35 @@                 tixPath <- liftM (pkgDir </>) $ parseRelFile $ exeName ++ ".tix"                 exePath <- liftM (buildDir </>) $ parseRelFile $ "build/" ++ testName' ++ "/" ++ exeName                 exists <- doesFileExist exePath-                menv <- liftIO $ configProcessContextSettings config EnvSettings+                -- doctest relies on template-haskell in QuickCheck-based tests+                thGhcId <- case find ((== "template-haskell") . pkgName . dpPackageIdent. snd)+                                (Map.toList $ eeGlobalDumpPkgs ee) of+                  Just (ghcId, _) -> return ghcId+                  Nothing -> error "template-haskell is a wired-in GHC boot library but it wasn't found"+                -- env variable GHC_ENVIRONMENT is set for doctest so module names for+                -- packages with proper dependencies should no longer get ambiguous+                -- see e.g. https://github.com/doctest/issues/119+                let setEnv f pc = modifyEnvVars pc $ \envVars ->+                      Map.insert "GHC_ENVIRONMENT" (T.pack f) envVars+                    fp = toFilePath $ eeTempDir ee </> testGhcEnvRelFile+                    snapDBPath = toFilePathNoTrailingSep (bcoSnapDB $ eeBaseConfigOpts ee)+                    localDBPath = toFilePathNoTrailingSep (bcoLocalDB $ eeBaseConfigOpts ee)+                    ghcEnv =+                        "clear-package-db\n" <>+                        "global-package-db\n" <>+                        "package-db " <> fromString snapDBPath <> "\n" <>+                        "package-db " <> fromString localDBPath <> "\n" <>+                        foldMap (\ghcId -> "package-id " <> RIO.display (unGhcPkgId ghcId) <> "\n")+                            (thGhcId:M.elems allDepsMap)+                writeFileUtf8Builder fp ghcEnv+                menv <- liftIO $ setEnv fp =<< configProcessContextSettings config EnvSettings                     { esIncludeLocals = taskLocation task == Local                     , esIncludeGhcPackagePath = True                     , esStackExe = True                     , esLocaleUtf8 = False                     , esKeepGhcRts = False                     }+                let emptyResult = Map.singleton testName Nothing                 withProcessContext menv $ if exists                     then do                         -- We clear out the .tix files before doing a run.@@ -1745,7 +1962,7 @@                             argsDisplay = case args of                                             [] -> ""                                             _ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args)-                        announce $ "test (suite: " <> testName <> argsDisplay <> ")"+                        announce $ "test (suite: " <> RIO.display testName <> RIO.display argsDisplay <> ")"                          -- Clear "Progress: ..." message before                         -- redirecting output.@@ -1756,48 +1973,75 @@                             liftIO $ hFlush stderr                           OTLogFile _ _ -> pure () -                        let output setter =+                        let output =                                 case outputType of-                                    OTConsole _ -> id-                                    OTLogFile _ h -> setter (useHandleOpen h)+                                    OTConsole Nothing -> Nothing <$ inherit+                                    OTConsole (Just prefix) -> fmap+                                      (\src -> Just $ runConduit $ src .|+                                               CT.decodeUtf8Lenient .|+                                               CT.lines .|+                                               CL.map stripCR .|+                                               CL.mapM_ (\t -> logInfo $ prefix <> RIO.display t))+                                      createSource+                                    OTLogFile _ h -> Nothing <$ useHandleOpen h+                            optionalTimeout action+                                | Just maxSecs <- toMaximumTimeSeconds topts, maxSecs > 0 = do+                                    timeout (maxSecs * 1000000) action+                                | otherwise = Just <$> action -                        ec <- withWorkingDir (toFilePath pkgDir) $-                          proc (toFilePath exePath) args $ \pc0 -> do-                            let pc = setStdin createPipe-                                   $ output setStdout-                                   $ output setStderr+                        mec <- withWorkingDir (toFilePath pkgDir) $+                          optionalTimeout $ proc (toFilePath exePath) args $ \pc0 -> do+                            stdinBS <-+                              if isTestTypeLib+                                then do+                                  logPath <- buildLogPath package (Just stestName)+                                  ensureDir (parent logPath)+                                  pure $ BL.fromStrict+                                       $ encodeUtf8 $ fromString $+                                       show (logPath, mkUnqualComponentName (T.unpack testName))+                                else pure mempty+                            let pc = setStdin (byteStringInput stdinBS)+                                   $ setStdout output+                                   $ setStderr output                                      pc0                             withProcess pc $ \p -> do-                              when isTestTypeLib $ do-                                logPath <- buildLogPath package (Just stestName)-                                ensureDir (parent logPath)-                                liftIO $ hPutStr (getStdin p) $ show (logPath, testName)+                              case (getStdout p, getStderr p) of+                                (Nothing, Nothing) -> pure ()+                                (Just x, Just y) -> concurrently_ x y+                                (x, y) -> assert False $ concurrently_ (fromMaybe (pure ()) x) (fromMaybe (pure ()) y)                               waitExitCode p                         -- Add a trailing newline, incase the test                         -- output didn't finish with a newline.                         case outputType of-                          OTConsole _ -> logInfo ""-                          OTLogFile _ _ -> pure ()+                          OTConsole Nothing -> logInfo ""+                          _ -> pure ()                         -- Move the .tix file out of the package                         -- directory into the hpc work dir, for                         -- tidiness.                         when needHpc $                             updateTixFile (packageName package) tixPath testName'-                        let announceResult result = announce $ "Test suite " <> testName <> " " <> result-                        case ec of-                            ExitSuccess -> do+                        let announceResult result = announce $ "Test suite " <> RIO.display testName <> " " <> result+                        case mec of+                            Just ExitSuccess -> do                                 announceResult "passed"                                 return Map.empty-                            _ -> do+                            Nothing -> do+                                announceResult "timed out"+                                if expectFailure+                                then return Map.empty+                                else return $ Map.singleton testName Nothing+                            Just ec -> do                                 announceResult "failed"-                                return $ Map.singleton testName (Just ec)+                                if expectFailure+                                then return Map.empty+                                else return $ Map.singleton testName (Just ec)                     else do-                        logError $ displayShow $ TestSuiteExeMissing+                        unless expectFailure $ logError $ displayShow $ TestSuiteExeMissing                             (packageBuildType package == C.Simple)                             exeName                             (packageNameString (packageName package))                             (T.unpack testName)-                        return $ Map.singleton testName Nothing+                        return emptyResult              when needHpc $ do                 let testsToRun' = map f testsToRun@@ -1814,7 +2058,7 @@                         hClose h                         S.readFile $ toFilePath logFile -            unless (Map.null errs) $ throwM $ TestSuiteFailure+            unless (Map.null errs || expectFailure) $ throwM $ TestSuiteFailure                 (taskProvides task)                 errs                 (case outputType of@@ -1850,17 +2094,20 @@          when toRun $ do             announce "benchmarks"-            cabal KeepTHLoading ("bench" : args)+            cabal CloseOnException KeepTHLoading ("bench" : args)  data ExcludeTHLoading = ExcludeTHLoading | KeepTHLoading data ConvertPathsToAbsolute = ConvertPathsToAbsolute | KeepPathsAsIs+-- | special marker for expected failures in curator builds, using those+-- we need to keep log handle open as build continues further even after a failure+data KeepOutputOpen = KeepOpen | CloseOnException deriving Eq  -- | Strip Template Haskell "Loading package" lines and making paths absolute. mungeBuildOutput :: forall m. MonadIO m                  => ExcludeTHLoading       -- ^ exclude TH loading?                  -> ConvertPathsToAbsolute -- ^ convert paths to absolute?                  -> Path Abs Dir           -- ^ package's root directory-                 -> CompilerVersion 'CVActual -- ^ compiler we're building with+                 -> ActualCompiler         -- ^ compiler we're building with                  -> ConduitM Text Text m () mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $     CT.lines@@ -1882,7 +2129,7 @@     filterLinkerWarnings         -- Check for ghc 7.8 since it's the only one prone to producing         -- linker warnings on Windows x64-        | getGhcVersion compilerVer >= $(mkVersion "7.8") = doNothing+        | getGhcVersion compilerVer >= mkVersion [7, 8] = doNothing         | otherwise = CL.filter (not . isLinkerWarning)      isLinkerWarning :: Text -> Bool@@ -1937,8 +2184,8 @@                 then return fp2                 else throwM $ NoSetupHsFound dir   where-    fp1 = dir </> $(mkRelFile "Setup.hs")-    fp2 = dir </> $(mkRelFile "Setup.lhs")+    fp1 = dir </> relFileSetupHs+    fp2 = dir </> relFileSetupLhs  -- Do not pass `-hpcdir` as GHC option if the coverage is not enabled. -- This helps running stack-compiled programs with dynamic interpreters like `hint`.@@ -1947,9 +2194,8 @@                   => WhichCompiler -> BuildOpts -> RIO env [String] extraBuildOptions wc bopts = do     colorOpt <- appropriateGhcColorFlag-    let ddumpOpts = " -ddump-hi -ddump-to-file"-        optsFlag = compilerOptionsCabalFlag wc-        baseOpts = ddumpOpts ++ maybe "" (" " ++) colorOpt+    let optsFlag = compilerOptionsCabalFlag wc+        baseOpts = maybe "" (" " ++) colorOpt     if toCoverage (boptsTestOpts bopts)       then do         hpcIndexDir <- toFilePathNoTrailingSep <$> hpcRelativeDir@@ -1967,7 +2213,7 @@          NoLibraries -> []          HasLibraries names ->              map T.unpack-           $ T.append "lib:" (packageNameText (packageName package))+           $ T.append "lib:" (T.pack (packageNameString (packageName package)))            : map (T.append "flib:") (Set.toList names)) ++       map (T.unpack . T.append "lib:") (Set.toList $ packageInternalLibraries package) ++       map (T.unpack . T.append "exe:") (Set.toList $ exesToBuild executableBuildStatuses lp)@@ -2007,8 +2253,8 @@ taskComponents :: Task -> Set NamedComponent taskComponents task =     case taskType task of-        TTFiles lp _ -> lpComponents lp -- FIXME probably just want Local, maybe even just lpWanted-        TTIndex{} -> Set.empty+        TTLocalMutable lp -> lpComponents lp -- FIXME probably just want lpWanted+        TTRemotePackage{} -> Set.empty  -- | Take the given list of package dependencies and the contents of the global -- package database, and construct a set of installed package IDs that:@@ -2028,7 +2274,7 @@ -- -- * https://github.com/commercialhaskell/stack/issues/949 addGlobalPackages :: Map PackageIdentifier GhcPkgId -- ^ dependencies of the package-                  -> [DumpPackage () () ()] -- ^ global packages+                  -> [DumpPackage] -- ^ global packages                   -> Set GhcPkgId addGlobalPackages deps globals0 =     res@@ -2045,7 +2291,7 @@      -- Create a Map of unique package names in the global database     globals2 = Map.fromListWith chooseBest-             $ map (packageIdentifierName . dpPackageIdent &&& id) globals1+             $ map (pkgName . dpPackageIdent &&& id) globals1      -- Final result: add in globals that have their dependencies met     res = loop id (Map.elems globals2) $ Set.fromList res0@@ -2055,18 +2301,18 @@     ----------------------------------      -- Is the given package identifier for any version of Cabal-    isCabal (PackageIdentifier name _) = name == $(mkPackageName "Cabal")+    isCabal (PackageIdentifier name _) = name == mkPackageName "Cabal"      -- Is the given package name provided by the package dependencies?-    isDep dp = packageIdentifierName (dpPackageIdent dp) `Set.member` depNames-    depNames = Set.map packageIdentifierName $ Map.keysSet deps+    isDep dp = pkgName (dpPackageIdent dp) `Set.member` depNames+    depNames = Set.map pkgName $ Map.keysSet deps      -- Choose the best of two competing global packages (the newest version)     chooseBest dp1 dp2         | getVer dp1 < getVer dp2 = dp2         | otherwise               = dp1       where-        getVer = packageIdentifierVersion . dpPackageIdent+        getVer = pkgVersion . dpPackageIdent      -- Are all dependencies of the given package met by the given Set of     -- installed packages@@ -2083,3 +2329,40 @@     -- None of the packages we checked can be added, therefore drop them all     -- and return our results     loop _ [] gids = gids+++expectTestFailure :: PackageName -> Maybe Curator -> Bool+expectTestFailure pname mcurator =+    maybe False (Set.member pname . curatorExpectTestFailure) mcurator++expectBenchmarkFailure :: PackageName -> Maybe Curator -> Bool+expectBenchmarkFailure pname mcurator =+    maybe False (Set.member pname . curatorExpectBenchmarkFailure) mcurator++fulfillCuratorBuildExpectations ::+       (HasLogFunc env, HasCallStack)+    => PackageName+    -> Maybe Curator+    -> Bool+    -> Bool+    -> b+    -> RIO env b+    -> RIO env b+fulfillCuratorBuildExpectations pname mcurator enableTests _ defValue action | enableTests &&+                                                                          expectTestFailure pname mcurator = do+    eres <- tryAny action+    case eres of+      Right res -> do+          logWarn $ fromString (packageNameString pname) <> ": unexpected test build success"+          return res+      Left _ -> return defValue+fulfillCuratorBuildExpectations pname mcurator _ enableBench defValue action | enableBench &&+                                                                          expectBenchmarkFailure pname mcurator = do+    eres <- tryAny action+    case eres of+      Right res -> do+          logWarn $ fromString (packageNameString pname) <> ": unexpected benchmark build success"+          return res+      Left _ -> return defValue+fulfillCuratorBuildExpectations _ _ _ _ _ action = do+    action
src/Stack/Build/Haddock.hs view
@@ -5,7 +5,6 @@ {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TemplateHaskell       #-}  -- | Generate haddocks module Stack.Build.Haddock@@ -26,22 +25,20 @@ import           Path import           Path.Extra import           Path.IO+import           RIO.List (intercalate)+import           RIO.PrettyPrint+import           Stack.Constants 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.Runner import qualified System.FilePath as FP import           RIO.Process import           Web.Browser (openBrowser)  openHaddocksInBrowser-    :: HasRunner env+    :: HasTerm env     => BaseConfigOpts     -> Map PackageName (PackageIdentifier, InstallLocation)     -- ^ Available packages and their locations for the current project@@ -80,7 +77,7 @@                             ", but that file is missing.  Opening doc index instead."                         getDocIndex             _ -> getDocIndex-    prettyInfo $ "Opening" <+> Stack.PrettyPrint.display docFile <+> "in the browser."+    prettyInfo $ "Opening" <+> pretty docFile <+> "in the browser."     _ <- liftIO $ openBrowser (toFilePath docFile)     return () @@ -102,13 +99,12 @@  -- | Generate Haddock index and contents for local packages. generateLocalHaddockIndex-    :: (HasProcessContext env, HasLogFunc env)-    => WhichCompiler-    -> BaseConfigOpts-    -> Map GhcPkgId (DumpPackage () () ())  -- ^ Local package dump+    :: (HasProcessContext env, HasLogFunc env, HasCompiler env)+    => BaseConfigOpts+    -> Map GhcPkgId DumpPackage  -- ^ Local package dump     -> [LocalPackage]     -> RIO env ()-generateLocalHaddockIndex wc bco localDumpPkgs locals = do+generateLocalHaddockIndex bco localDumpPkgs locals = do     let dumpPackages =             mapMaybe                 (\LocalPackage{lpPackage = Package{..}} ->@@ -118,7 +114,6 @@                 locals     generateHaddockIndex         "local packages"-        wc         bco         dumpPackages         "."@@ -126,20 +121,18 @@  -- | Generate Haddock index and contents for local packages and their dependencies. generateDepsHaddockIndex-    :: (HasProcessContext env, HasLogFunc env)-    => WhichCompiler-    -> BaseConfigOpts-    -> Map GhcPkgId (DumpPackage () () ())  -- ^ Global dump information-    -> Map GhcPkgId (DumpPackage () () ())  -- ^ Snapshot dump information-    -> Map GhcPkgId (DumpPackage () () ())  -- ^ Local dump information+    :: (HasProcessContext env, HasLogFunc env, HasCompiler env)+    => BaseConfigOpts+    -> Map GhcPkgId DumpPackage  -- ^ Global dump information+    -> Map GhcPkgId DumpPackage  -- ^ Snapshot dump information+    -> Map GhcPkgId DumpPackage  -- ^ Local dump information     -> [LocalPackage]     -> RIO env ()-generateDepsHaddockIndex wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do+generateDepsHaddockIndex bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do     let deps = (mapMaybe (`lookupDumpPackage` allDumpPkgs) . nubOrd . findTransitiveDepends . mapMaybe getGhcPkgId) locals         depDocDir = localDepsDocDir bco     generateHaddockIndex         "local packages and dependencies"-        wc         bco         deps         ".."@@ -169,16 +162,14 @@  -- | Generate Haddock index and contents for all snapshot packages. generateSnapHaddockIndex-    :: (HasProcessContext env, HasLogFunc env)-    => WhichCompiler-    -> BaseConfigOpts-    -> Map GhcPkgId (DumpPackage () () ())  -- ^ Global package dump-    -> Map GhcPkgId (DumpPackage () () ())  -- ^ Snapshot package dump+    :: (HasProcessContext env, HasLogFunc env, HasCompiler env)+    => BaseConfigOpts+    -> Map GhcPkgId DumpPackage  -- ^ Global package dump+    -> Map GhcPkgId DumpPackage  -- ^ Snapshot package dump     -> RIO env ()-generateSnapHaddockIndex wc bco globalDumpPkgs snapshotDumpPkgs =+generateSnapHaddockIndex bco globalDumpPkgs snapshotDumpPkgs =     generateHaddockIndex         "snapshot packages"-        wc         bco         (Map.elems snapshotDumpPkgs ++ Map.elems globalDumpPkgs)         "."@@ -186,15 +177,14 @@  -- | Generate Haddock index and contents for specified packages. generateHaddockIndex-    :: (HasProcessContext env, HasLogFunc env)+    :: (HasProcessContext env, HasLogFunc env, HasCompiler env)     => Text-    -> WhichCompiler     -> BaseConfigOpts-    -> [DumpPackage () () ()]+    -> [DumpPackage]     -> FilePath     -> Path Abs Dir     -> RIO env ()-generateHaddockIndex descr wc bco dumpPackages docRelFP destDir = do+generateHaddockIndex descr bco dumpPackages docRelFP destDir = do     ensureDir destDir     interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages     unless (null interfaceOpts) $ do@@ -213,8 +203,9 @@                   " in\n" <>                   fromString (toFilePath destIndexFile)                 liftIO (mapM_ copyPkgDocs interfaceOpts)+                haddockExeName <- view $ compilerPathsL.to (toFilePath . cpHaddock)                 withWorkingDir (toFilePath destDir) $ readProcessNull-                    (haddockExeName wc)+                    haddockExeName                     (map (("--optghc=-package-db=" ++ ) . toFilePathNoTrailingSep)                         [bcoSnapDB bco, bcoLocalDB bco] ++                      hoAdditionalArgs (boptsHaddockOpts (bcoBuildOpts bco)) ++@@ -227,7 +218,7 @@                 " already up to date at:\n" <>                 fromString (toFilePath destIndexFile)   where-    toInterfaceOpt :: DumpPackage a b c -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))+    toInterfaceOpt :: DumpPackage -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))     toInterfaceOpt DumpPackage {..} =         case dpHaddockInterfaces of             [] -> return Nothing@@ -238,6 +229,9 @@                         docRelFP FP.</>                         packageIdentifierString dpPackageIdent FP.</>                         (packageNameString name FP.<.> "haddock")+                    interfaces = intercalate "," $+                      maybeToList dpHaddockHtml ++ [srcInterfaceFP]+                 destInterfaceAbsFile <- parseCollapsedAbsFile (toFilePath destDir FP.</> destInterfaceRelFP)                 esrcInterfaceModTime <- tryGetModificationTime srcInterfaceAbsFile                 return $@@ -245,11 +239,7 @@                         Left _ -> Nothing                         Right srcInterfaceModTime ->                             Just-                                ( [ "-i"-                                  , concat-                                        [ docRelFP FP.</> packageIdentifierString dpPackageIdent-                                        , ","-                                        , destInterfaceRelFP ]]+                                ( [ "-i", interfaces ]                                 , srcInterfaceModTime                                 , srcInterfaceAbsFile                                 , destInterfaceAbsFile )@@ -278,14 +268,14 @@  -- | Find first DumpPackage matching the GhcPkgId lookupDumpPackage :: GhcPkgId-                  -> [Map GhcPkgId (DumpPackage () () ())]-                  -> Maybe (DumpPackage () () ())+                  -> [Map GhcPkgId DumpPackage]+                  -> Maybe DumpPackage lookupDumpPackage ghcPkgId dumpPkgs =     listToMaybe $ mapMaybe (Map.lookup ghcPkgId) dumpPkgs  -- | Path of haddock index file. haddockIndexFile :: Path Abs Dir -> Path Abs File-haddockIndexFile destDir = destDir </> $(mkRelFile "index.html")+haddockIndexFile destDir = destDir </> relFileIndexHtml  -- | Path of local packages documentation directory. localDocDir :: BaseConfigOpts -> Path Abs Dir@@ -293,7 +283,7 @@  -- | Path of documentation directory for the dependencies of local packages localDepsDocDir :: BaseConfigOpts -> Path Abs Dir-localDepsDocDir bco = localDocDir bco </> $(mkRelDir "all")+localDepsDocDir bco = localDocDir bco </> relDirAll  -- | Path of snapshot packages documentation directory. snapDocDir :: BaseConfigOpts -> Path Abs Dir
src/Stack/Build/Installed.hs view
@@ -7,14 +7,14 @@ module Stack.Build.Installed     ( InstalledMap     , Installed (..)-    , GetInstalledOpts (..)     , getInstalled+    , InstallMap+    , toInstallMap     ) where  import           Data.Conduit import qualified Data.Conduit.List as CL-import qualified Data.Foldable as F-import qualified Data.HashSet as HashSet+import qualified Data.Set as Set import           Data.List import qualified Data.Map.Strict as Map import           Path@@ -22,48 +22,45 @@ import           Stack.Constants import           Stack.PackageDump import           Stack.Prelude+import           Stack.SourceMap (getPLIVersion, loadVersion) import           Stack.Types.Build import           Stack.Types.Compiler import           Stack.Types.Config import           Stack.Types.GhcPkgId import           Stack.Types.Package-import           Stack.Types.PackageDump-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Version+import           Stack.Types.SourceMap --- | Options for 'getInstalled'.-data GetInstalledOpts = GetInstalledOpts-    { getInstalledProfiling :: !Bool-      -- ^ Require profiling libraries?-    , getInstalledHaddock   :: !Bool-      -- ^ Require haddocks?-    , getInstalledSymbols   :: !Bool-      -- ^ Require debugging symbols?-    }+toInstallMap :: MonadIO m => SourceMap -> m InstallMap+toInstallMap sourceMap = do+    projectInstalls <-+        for (smProject sourceMap) $ \pp -> do+            version <- loadVersion (ppCommon pp)+            return (Local, version)+    depInstalls <-+        for (smDeps sourceMap) $ \dp ->+            case dpLocation dp of+                PLImmutable pli -> pure (Snap, getPLIVersion pli)+                PLMutable _ -> do+                    version <- loadVersion (dpCommon dp)+                    return (Local, version)+    return $ projectInstalls <> depInstalls  -- | Returns the new InstalledMap and all of the locally registered packages. getInstalled :: HasEnvConfig env-             => GetInstalledOpts-             -> Map PackageName PackageSource -- ^ does not contain any installed information+             => InstallMap -- ^ does not contain any installed information              -> RIO env                   ( InstalledMap-                  , [DumpPackage () () ()] -- globally installed-                  , [DumpPackage () () ()] -- snapshot installed-                  , [DumpPackage () () ()] -- locally installed+                  , [DumpPackage] -- globally installed+                  , [DumpPackage] -- snapshot installed+                  , [DumpPackage] -- locally installed                   )-getInstalled opts sourceMap = do+getInstalled {-opts-} installMap = do     logDebug "Finding out which packages are already installed"     snapDBPath <- packageDatabaseDeps     localDBPath <- packageDatabaseLocal     extraDBPaths <- packageDatabaseExtra -    mcache <--        if getInstalledProfiling opts || getInstalledHaddock opts-            then configInstalledCache >>= liftM Just . loadInstalledCache-            else return Nothing--    let loadDatabase' = loadDatabase opts mcache sourceMap+    let loadDatabase' = loadDatabase {-opts mcache-} installMap      (installedLibs0, globalDumpPkgs) <- loadDatabase' Nothing []     (installedLibs1, _extraInstalled) <-@@ -76,24 +73,24 @@         loadDatabase' (Just (InstalledTo Local, localDBPath)) installedLibs2     let installedLibs = Map.fromList $ map lhPair installedLibs3 -    F.forM_ mcache $ \cache -> do-        icache <- configInstalledCache-        saveInstalledCache icache cache-     -- Add in the executables that are installed, making sure to only trust a     -- listed installation under the right circumstances (see below)     let exesToSM loc = Map.unions . map (exeToSM loc)         exeToSM loc (PackageIdentifier name version) =-            case Map.lookup name sourceMap of+            case Map.lookup name installMap of                 -- Doesn't conflict with anything, so that's OK                 Nothing -> m-                Just pii+                Just (iLoc, iVersion)                     -- Not the version we want, ignore it-                    | version /= piiVersion pii || loc /= piiLocation pii -> Map.empty+                    | version /= iVersion || mismatchingLoc loc iLoc -> Map.empty                      | otherwise -> m           where             m = Map.singleton name (loc, Executable $ PackageIdentifier name version)+            mismatchingLoc installed target | target == installed = False+                                            | installed == Local = False -- snapshot dependency could end up+                                                                         -- in a local install as being mutable+                                            | otherwise = True     exesSnap <- getInstalledExes Snap     exesLocal <- getInstalledExes Local     let installedMap = Map.unions@@ -114,15 +111,14 @@ -- that it has profiling if necessary, and that it matches the version and -- location needed by the SourceMap loadDatabase :: HasEnvConfig env-             => GetInstalledOpts-             -> Maybe InstalledCache -- ^ if Just, profiling or haddock is required-             -> Map PackageName PackageSource -- ^ to determine which installed things we should include+             => InstallMap -- ^ to determine which installed things we should include              -> Maybe (InstalledPackageLocation, Path Abs Dir) -- ^ package database, Nothing for global              -> [LoadHelper] -- ^ from parent databases-             -> RIO env ([LoadHelper], [DumpPackage () () ()])-loadDatabase opts mcache sourceMap mdb lhs0 = do+             -> RIO env ([LoadHelper], [DumpPackage])+loadDatabase installMap mdb lhs0 = do     wc <- view $ actualCompilerVersionL.to whichCompiler-    (lhs1', dps) <- ghcPkgDump wc (fmap snd (maybeToList mdb))+    pkgexe <- getGhcPkgExe+    (lhs1', dps) <- ghcPkgDump pkgexe (fmap snd (maybeToList mdb))                 $ conduitDumpPackage .| sink     let ghcjsHack = wc == Ghcjs && isNothing mdb     lhs1 <- mapMaybeM (processLoadResult mdb ghcjsHack) lhs1'@@ -134,29 +130,8 @@             (lhs0 ++ lhs1)     return (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, dps)   where-    conduitProfilingCache =-        case mcache of-            Just cache | getInstalledProfiling opts -> addProfiling cache-            -- Just an optimization to avoid calculating the profiling-            -- values when they aren't necessary-            _ -> CL.map (\dp -> dp { dpProfiling = False })-    conduitHaddockCache =-        case mcache of-            Just cache | getInstalledHaddock opts -> addHaddock cache-            -- Just an optimization to avoid calculating the haddock-            -- values when they aren't necessary-            _ -> CL.map (\dp -> dp { dpHaddock = False })-    conduitSymbolsCache =-        case mcache of-            Just cache | getInstalledSymbols opts -> addSymbols cache-            -- Just an optimization to avoid calculating the debugging-            -- symbol values when they aren't necessary-            _ -> CL.map (\dp -> dp { dpSymbols = False })     mloc = fmap fst mdb-    sinkDP = conduitProfilingCache-           .| conduitHaddockCache-           .| conduitSymbolsCache-           .| CL.map (isAllowed opts mcache sourceMap mloc &&& toLoadHelper mloc)+    sinkDP =  CL.map (isAllowed installMap mloc &&& toLoadHelper mloc)            .| CL.consume     sink = getZipSink $ (,)         <$> ZipSink sinkDP@@ -171,40 +146,34 @@ processLoadResult _ True (WrongVersion actual wanted, lh)     -- Allow some packages in the ghcjs global DB to have the wrong     -- versions.  Treat them as wired-ins by setting deps to [].-    | fst (lhPair lh) `HashSet.member` ghcjsBootPackages = do+    | fst (lhPair lh) `Set.member` ghcjsBootPackages = do         logWarn $             "Ignoring that the GHCJS boot package \"" <>-            display (packageNameText (fst (lhPair lh))) <>+            fromString (packageNameString (fst (lhPair lh))) <>             "\" has a different version, " <>-            display (versionText actual) <>+            fromString (versionString actual) <>             ", than the resolver's wanted version, " <>-            display (versionText wanted)+            fromString (versionString wanted)         return (Just lh) processLoadResult mdb _ (reason, lh) = do     logDebug $         "Ignoring package " <>-        display (packageNameText (fst (lhPair lh))) <>+        fromString (packageNameString (fst (lhPair lh))) <>         maybe mempty (\db -> ", from " <> displayShow db <> ",") mdb <>         " due to" <>         case reason of             Allowed -> " the impossible?!?!"-            NeedsProfiling -> " it needing profiling."-            NeedsHaddock -> " it needing haddocks."-            NeedsSymbols -> " it needing debugging symbols."             UnknownPkg -> " it being unknown to the resolver / extra-deps."             WrongLocation mloc loc -> " wrong location: " <> displayShow (mloc, loc)             WrongVersion actual wanted ->                 " wanting version " <>-                display (versionText wanted) <>+                fromString (versionString wanted) <>                 " instead of " <>-                display (versionText actual)+                fromString (versionString actual)     return Nothing  data Allowed     = Allowed-    | NeedsProfiling-    | NeedsHaddock-    | NeedsSymbols     | UnknownPkg     | WrongLocation (Maybe InstalledPackageLocation) InstallLocation     | WrongVersion Version Version@@ -213,31 +182,22 @@ -- | Check if a can be included in the set of installed packages or not, based -- on the package selections made by the user. This does not perform any -- dirtiness or flag change checks.-isAllowed :: GetInstalledOpts-          -> Maybe InstalledCache-          -> Map PackageName PackageSource+isAllowed :: InstallMap           -> Maybe InstalledPackageLocation-          -> DumpPackage Bool Bool Bool+          -> DumpPackage           -> Allowed-isAllowed opts mcache sourceMap mloc dp-    -- Check that it can do profiling if necessary-    | getInstalledProfiling opts && isJust mcache && not (dpProfiling dp) = NeedsProfiling-    -- Check that it has haddocks if necessary-    | getInstalledHaddock opts && isJust mcache && not (dpHaddock dp) = NeedsHaddock-    -- Check that it has haddocks if necessary-    | getInstalledSymbols opts && isJust mcache && not (dpSymbols dp) = NeedsSymbols-    | otherwise =-        case Map.lookup name sourceMap of+isAllowed installMap mloc dp =+        case Map.lookup name installMap of             Nothing ->                 -- If the sourceMap has nothing to say about this package,                 -- check if it represents a sublibrary first                 -- See: https://github.com/commercialhaskell/stack/issues/3899                 case dpParentLibIdent dp of                   Just (PackageIdentifier parentLibName version') ->-                    case Map.lookup parentLibName sourceMap of+                    case Map.lookup parentLibName installMap of                       Nothing -> checkNotFound-                      Just pii-                        | version' == version -> checkFound pii+                      Just instInfo+                        | version' == version -> checkFound instInfo                         | otherwise -> checkNotFound -- different versions                   Nothing -> checkNotFound             Just pii -> checkFound pii@@ -245,12 +205,12 @@     PackageIdentifier name version = dpPackageIdent dp     -- Ensure that the installed location matches where the sourceMap says it     -- should be installed-    checkLocation Snap = mloc /= Just (InstalledTo Local) -- we can allow either global or snap+    checkLocation Snap = True -- snapshot deps could become mutable after getting any mutable dependency     checkLocation Local = mloc == Just (InstalledTo Local) || mloc == Just ExtraGlobal -- 'locally' installed snapshot packages can come from extra dbs     -- Check if a package is allowed if it is found in the sourceMap-    checkFound pii-      | not (checkLocation (piiLocation pii)) = WrongLocation mloc (piiLocation pii)-      | version /= piiVersion pii = WrongVersion version (piiVersion pii)+    checkFound (installLoc, installVer)+      | not (checkLocation installLoc) = WrongLocation mloc installLoc+      | version /= installVer = WrongVersion version installVer       | otherwise = Allowed     -- check if a package is allowed if it is not found in the sourceMap     checkNotFound = case mloc of@@ -268,7 +228,7 @@     }     deriving Show -toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage Bool Bool Bool -> LoadHelper+toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage -> LoadHelper toLoadHelper mloc dp = LoadHelper     { lhId = gid     , lhDeps =@@ -278,7 +238,7 @@         -- minor versions of GHC, where the dependencies of wired-in         -- packages may change slightly and therefore not match the         -- snapshot.-        if name `HashSet.member` wiredInPackages+        if name `Set.member` wiredInPackages             then []             else dpDepends dp     , lhPair = (name, (toPackageLocation mloc, Library ident gid (Right <$> dpLicense dp)))
src/Stack/Build/Source.hs view
@@ -2,136 +2,211 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE ConstraintKinds #-} -- Load information on package sources module Stack.Build.Source-    ( loadSourceMap-    , loadSourceMapFull-    , SourceMap+    ( projectLocalPackages+    , localDependencies+    , loadCommonPackage+    , loadLocalPackage+    , loadSourceMap     , getLocalFlags-    , getGhcOptions     , addUnlistedToBuildCache+    , hashSourceMapData     ) where  import              Stack.Prelude-import              Crypto.Hash (Digest, SHA256(..))-import              Crypto.Hash.Conduit (sinkHash)-import qualified    Data.ByteArray as Mem (convert)+import qualified    Pantry.SHA256 as SHA256 import qualified    Data.ByteString as S-import              Data.Conduit (ZipSink (..))+import              Data.ByteString.Builder (toLazyByteString)+import              Conduit (ZipSink (..), withSourceFile) import qualified    Data.Conduit.List as CL-import qualified    Data.HashSet as HashSet+import qualified    Distribution.PackageDescription as C import              Data.List import qualified    Data.Map as Map import qualified    Data.Map.Strict as M import qualified    Data.Set as Set+import              Foreign.C.Types (CTime) import              Stack.Build.Cache+import              Stack.Build.Haddock (shouldHaddockDeps) import              Stack.Build.Target-import              Stack.Config (getLocalPackages)-import              Stack.Constants (wiredInPackages) import              Stack.Package-import              Stack.PackageLocation+import              Stack.SourceMap import              Stack.Types.Build-import              Stack.Types.BuildPlan import              Stack.Types.Config-import              Stack.Types.FlagName import              Stack.Types.NamedComponent import              Stack.Types.Package-import              Stack.Types.PackageName-import qualified    System.Directory as D+import              Stack.Types.SourceMap import              System.FilePath (takeFileName) import              System.IO.Error (isDoesNotExistError)+import              System.PosixCompat.Files (modificationTime, getFileStatus) --- | Like 'loadSourceMapFull', but doesn't return values that aren't as--- commonly needed.-loadSourceMap :: HasEnvConfig env-              => NeedTargets+-- | loads and returns project packages+projectLocalPackages :: HasEnvConfig env+              => RIO env [LocalPackage]+projectLocalPackages = do+    sm <- view $ envConfigL.to envConfigSourceMap+    for (toList $ smProject sm) loadLocalPackage++-- | loads all local dependencies - project packages and local extra-deps+localDependencies :: HasEnvConfig env => RIO env [LocalPackage]+localDependencies = do+    bopts <- view $ configL.to configBuild+    sourceMap <- view $ envConfigL . to envConfigSourceMap+    forMaybeM (Map.elems $ smDeps sourceMap) $ \dp ->+        case dpLocation dp of+            PLMutable dir -> do+                pp <- mkProjectPackage YesPrintWarnings dir (shouldHaddockDeps bopts)+                Just <$> loadLocalPackage pp+            _ -> return Nothing++-- | Given the parsed targets and build command line options constructs+--   a source map+loadSourceMap :: HasBuildConfig env+              => SMTargets               -> BuildOptsCLI-              -> RIO env ([LocalPackage], SourceMap)-loadSourceMap needTargets boptsCli = do-    (_, _, locals, _, sourceMap) <- loadSourceMapFull needTargets boptsCli-    return (locals, sourceMap)+              -> SMActual DumpedGlobalPackage+              -> RIO env SourceMap+loadSourceMap smt boptsCli sma = do+    bconfig <- view buildConfigL+    let compiler = smaCompiler sma+        project = M.map applyOptsFlagsPP $ smaProject sma+        bopts = configBuild (bcConfig bconfig)+        applyOptsFlagsPP p@ProjectPackage{ppCommon = c} =+          p{ppCommon = applyOptsFlags (M.member (cpName c) (smtTargets smt)) True c}+        deps0 = smtDeps smt <> smaDeps sma+        deps = M.map applyOptsFlagsDep deps0+        applyOptsFlagsDep d@DepPackage{dpCommon = c} =+          d{dpCommon = applyOptsFlags (M.member (cpName c) (smtDeps smt)) False c}+        applyOptsFlags isTarget isProjectPackage common =+            let name = cpName common+                flags = getLocalFlags boptsCli name+                ghcOptions =+                  generalGhcOptions bconfig boptsCli isTarget isProjectPackage+                cabalConfigOpts =+                  loadCabalConfigOpts bconfig (cpName common) isTarget isProjectPackage+            in common+               { cpFlags =+                     if M.null flags+                         then cpFlags common+                         else flags+               , cpGhcOptions =+                     ghcOptions ++ cpGhcOptions common+               , cpCabalConfigOpts =+                     cabalConfigOpts ++ cpCabalConfigOpts common+               , cpHaddocks =+                     if isTarget+                         then boptsHaddock bopts+                         else shouldHaddockDeps bopts+               }+        packageCliFlags = Map.fromList $+          mapMaybe maybeProjectFlags $+          Map.toList (boptsCLIFlags boptsCli)+        maybeProjectFlags (ACFByName name, fs) = Just (name, fs)+        maybeProjectFlags _ = Nothing+        globals = pruneGlobals (smaGlobal sma) (Map.keysSet deps)+    logDebug "Checking flags"+    checkFlagsUsedThrowing packageCliFlags FSCommandLine project deps+    logDebug "SourceMap constructed"+    return+        SourceMap+        { smTargets = smt+        , smCompiler = compiler+        , smProject = project+        , smDeps = deps+        , smGlobal = globals+        } --- | Given the build commandline options, does the following:+-- | Get a 'SourceMapHash' for a given 'SourceMap' ----- * Parses the build targets.+-- Basic rules: ----- * Loads the 'LoadedSnapshot' from the resolver, with extra-deps---   shadowing any packages that should be built locally.+-- * If someone modifies a GHC installation in any way after Stack+--   looks at it, they voided the warranty. This includes installing a+--   brand new build to the same directory, or registering new+--   packages to the global database. ----- * Loads up the 'LocalPackage' info.+-- * We should include everything in the hash that would relate to+--   immutable packages and identifying the compiler itself. Mutable+--   packages (both project packages and dependencies) will never make+--   it into the snapshot database, and can be ignored. ----- * Builds a 'SourceMap', which contains info for all the packages that---   will be involved in the build.-loadSourceMapFull :: HasEnvConfig env-                  => NeedTargets-                  -> BuildOptsCLI-                  -> RIO env-                       ( Map PackageName Target-                       , LoadedSnapshot-                       , [LocalPackage] -- FIXME do we really want this? it's in the SourceMap-                       , Set PackageName -- non-project targets-                       , SourceMap-                       )-loadSourceMapFull needTargets boptsCli = do-    bconfig <- view buildConfigL-    (ls, localDeps, targets) <- parseTargets needTargets boptsCli-    lp <- getLocalPackages-    locals <- mapM (loadLocalPackage True boptsCli targets) $ Map.toList $ lpProject lp-    checkFlagsUsed boptsCli locals localDeps (lsPackages ls)-    checkComponentsBuildable locals--    -- TODO for extra sanity, confirm that the targets we threw away are all TargetAll-    let nonProjectTargets = Map.keysSet targets `Set.difference` Map.keysSet (lpProject lp)--    -- Combine the local packages, extra-deps, and LoadedSnapshot into-    -- one unified source map.-    let goLPI loc n lpi = do-          let configOpts = getGhcOptions bconfig boptsCli n False False-          case lpiLocation lpi of-            -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon-            PLIndex pir -> return $ PSIndex loc (lpiFlags lpi) configOpts pir-            PLOther pl -> do-              root <- view projectRootL-              lpv <- parseSingleCabalFile root True pl-              lp' <- loadLocalPackage False boptsCli targets (n, lpv)-              return $ PSFiles lp' loc-    sourceMap' <- Map.unions <$> sequence-      [ return $ Map.fromList $ map (\lp' -> (packageName $ lpPackage lp', PSFiles lp' Local)) locals-      , sequence $ Map.mapWithKey (goLPI Local) localDeps-      , sequence $ Map.mapWithKey (goLPI Snap) (lsPackages ls)-      ]-    let sourceMap = sourceMap'-            `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages))+-- * Target information is only relevant insofar as it effects the+--   dependency map. The actual current targets for this build are+--   irrelevant to the cache mechanism, and can be ignored.+--+-- * Make sure things like profiling and haddocks are included in the hash+--+hashSourceMapData+    :: (HasBuildConfig env, HasCompiler env)+    => BuildOptsCLI+    -> SourceMap+    -> RIO env SourceMapHash+hashSourceMapData boptsCli sm = do+    compilerPath <- getUtf8Builder . fromString . toFilePath <$> getCompilerPath+    compilerInfo <- getCompilerInfo+    immDeps <- forM (Map.elems (smDeps sm)) depPackageHashableContent+    bc <- view buildConfigL+    let -- extra bytestring specifying GHC options supposed to be applied to+        -- GHC boot packages so we'll have differrent hashes when bare+        -- resolver 'ghc-X.Y.Z' is used, no extra-deps and e.g. user wants builds+        -- with profiling or without+        bootGhcOpts = map display (generalGhcOptions bc boptsCli False False)+        hashedContent = toLazyByteString $ compilerPath <> compilerInfo <>+            getUtf8Builder (mconcat bootGhcOpts) <> mconcat immDeps+    return $ SourceMapHash (SHA256.hashLazyBytes hashedContent) -    return-      ( targets-      , ls-      , locals-      , nonProjectTargets-      , sourceMap-      )+depPackageHashableContent :: (HasConfig env) => DepPackage -> RIO env Builder+depPackageHashableContent DepPackage {..} = do+    case dpLocation of+        PLMutable _ -> return ""+        PLImmutable pli -> do+            let flagToBs (f, enabled) =+                    if enabled+                        then ""+                        else "-" <> fromString (C.unFlagName f)+                flags = map flagToBs $ Map.toList (cpFlags dpCommon)+                ghcOptions = map display (cpGhcOptions dpCommon)+                cabalConfigOpts = map display (cpCabalConfigOpts dpCommon)+                haddocks = if cpHaddocks dpCommon then "haddocks" else ""+                hash = immutableLocSha pli+            return $ hash <> haddocks <> getUtf8Builder (mconcat flags) <>+                getUtf8Builder (mconcat ghcOptions) <>+                getUtf8Builder (mconcat cabalConfigOpts)  -- | All flags for a local package. getLocalFlags-    :: BuildConfig-    -> BuildOptsCLI+    :: BuildOptsCLI     -> PackageName     -> Map FlagName Bool-getLocalFlags bconfig boptsCli name = Map.unions-    [ Map.findWithDefault Map.empty (Just name) cliFlags-    , Map.findWithDefault Map.empty Nothing cliFlags-    , Map.findWithDefault Map.empty name (bcFlags bconfig)+getLocalFlags boptsCli name = Map.unions+    [ Map.findWithDefault Map.empty (ACFByName name) cliFlags+    , Map.findWithDefault Map.empty ACFAllProjectPackages cliFlags     ]   where     cliFlags = boptsCLIFlags boptsCli +-- | Get the options to pass to @./Setup.hs configure@+loadCabalConfigOpts :: BuildConfig -> PackageName -> Bool -> Bool -> [Text]+loadCabalConfigOpts bconfig name isTarget isLocal = concat+    [ Map.findWithDefault [] CCKEverything (configCabalConfigOpts config)+    , if isLocal+        then Map.findWithDefault [] CCKLocals (configCabalConfigOpts config)+        else []+    , if isTarget+        then Map.findWithDefault [] CCKTargets (configCabalConfigOpts config)+        else []+    , Map.findWithDefault [] (CCKPackage name) (configCabalConfigOpts config)+    ]+  where+    config = view configL bconfig+ -- | Get the configured options to pass from GHC, based on the build -- configuration and commandline.-getGhcOptions :: BuildConfig -> BuildOptsCLI -> PackageName -> Bool -> Bool -> [Text]-getGhcOptions bconfig boptsCli name isTarget isLocal = concat+generalGhcOptions :: BuildConfig -> BuildOptsCLI -> Bool -> Bool -> [Text]+generalGhcOptions bconfig boptsCli isTarget isLocal = concat     [ Map.findWithDefault [] AGOEverything (configGhcOptionsByCat config)     , if isLocal         then Map.findWithDefault [] AGOLocals (configGhcOptionsByCat config)@@ -139,7 +214,6 @@     , if isTarget         then Map.findWithDefault [] AGOTargets (configGhcOptionsByCat config)         else []-    , Map.findWithDefault [] name (configGhcOptionsByName config)     , concat [["-fhpc"] | isLocal && toCoverage (boptsTestOpts bopts)]     , if boptsLibProfile bopts || boptsExeProfile bopts          then ["-fprof-auto","-fprof-cafs"]@@ -172,31 +246,39 @@     go a b c (CTest x:xs) = go a (b . (x:)) c xs     go a b c (CBench x:xs) = go a b (c . (x:)) xs --- | Upgrade the initial local package info to a full-blown @LocalPackage@+loadCommonPackage ::+       forall env. (HasBuildConfig env, HasSourceMap env)+    => CommonPackage+    -> RIO env Package+loadCommonPackage common = do+    config <- getPackageConfig (cpFlags common) (cpGhcOptions common) (cpCabalConfigOpts common)+    gpkg <- liftIO $ cpGPD common+    return $ resolvePackage config gpkg++-- | Upgrade the initial project package info to a full-blown @LocalPackage@ -- based on the selected components-loadLocalPackage-    :: forall env. HasEnvConfig env-    => Bool-    -- ^ Should this be treated as part of $locals? False for extra-deps.-    ---    -- See: https://github.com/commercialhaskell/stack/issues/3574#issuecomment-346512821-    -> BuildOptsCLI-    -> Map PackageName Target-    -> (PackageName, LocalPackageView)+loadLocalPackage ::+       forall env. (HasBuildConfig env, HasSourceMap env)+    => ProjectPackage     -> RIO env LocalPackage-loadLocalPackage isLocal boptsCli targets (name, lpv) = do-    let mtarget = Map.lookup name targets-    config  <- getPackageConfig boptsCli name (isJust mtarget) isLocal+loadLocalPackage pp = do+    sm <- view sourceMapL+    let common = ppCommon pp     bopts <- view buildOptsL-    let (exeCandidates, testCandidates, benchCandidates) =+    mcurator <- view $ buildConfigL.to bcCurator+    config <- getPackageConfig (cpFlags common) (cpGhcOptions common) (cpCabalConfigOpts common)+    gpkg <- ppGPD pp+    let name = cpName common+        mtarget = M.lookup name (smtTargets $ smTargets sm)+        (exeCandidates, testCandidates, benchCandidates) =             case mtarget of                 Just (TargetComps comps) -> splitComponents $ Set.toList comps                 Just (TargetAll _packageType) ->                     ( packageExes pkg-                    , if boptsTests bopts+                    , if boptsTests bopts && maybe True (Set.notMember name . curatorSkipTest) mcurator                         then Map.keysSet (packageTests pkg)                         else Set.empty-                    , if boptsBenchmarks bopts+                    , if boptsBenchmarks bopts && maybe True (Set.notMember name . curatorSkipBenchmark) mcurator                         then packageBenchmarks pkg                         else Set.empty                     )@@ -260,7 +342,6 @@         -- This allows us to do an optimization where these are passed         -- if the deps are present. This can avoid doing later         -- unnecessary reconfigures.-        gpkg = lpvGPD lpv         pkg = resolvePackage config gpkg         btpkg             | Set.null tests && Set.null benches = Nothing@@ -268,21 +349,29 @@         testpkg = resolvePackage testconfig gpkg         benchpkg = resolvePackage benchconfig gpkg -    (componentFiles,_) <- getPackageFilesForTargets pkg (lpvCabalFP lpv) nonLibComponents+    componentFiles <- memoizeRefWith $ fst <$> getPackageFilesForTargets pkg (ppCabalFP pp) nonLibComponents -    checkCacheResults <- forM (Map.toList componentFiles) $ \(component, files) -> do-        mbuildCache <- tryGetBuildCache (lpvRoot lpv) component+    checkCacheResults <- memoizeRefWith $ do+      componentFiles' <- runMemoizedWith componentFiles+      forM (Map.toList componentFiles') $ \(component, files) -> do+        mbuildCache <- tryGetBuildCache (ppRoot pp) component         checkCacheResult <- checkBuildCache             (fromMaybe Map.empty mbuildCache)             (Set.toList files)         return (component, checkCacheResult) -    let allDirtyFiles =-            Set.unions $-                map (\(_, (dirtyFiles, _)) -> dirtyFiles) checkCacheResults+    let dirtyFiles = do+          checkCacheResults' <- checkCacheResults+          let allDirtyFiles = Set.unions $ map (\(_, (x, _)) -> x) checkCacheResults'+          pure $+            if not (Set.null allDirtyFiles)+                then let tryStripPrefix y =+                          fromMaybe y (stripPrefix (toFilePath $ ppRoot pp) y)+                      in Just $ Set.map tryStripPrefix allDirtyFiles+                else Nothing         newBuildCaches =-            M.fromList $-                map (\(c, (_, cache)) -> (c, cache)) checkCacheResults+            M.fromList . map (\(c, (_, cache)) -> (c, cache))+            <$> checkCacheResults      return LocalPackage         { lpPackage = pkg@@ -290,16 +379,11 @@         , lpBenchDeps = dvVersionRange <$> packageDeps benchpkg         , lpTestBench = btpkg         , lpComponentFiles = componentFiles+        , lpBuildHaddocks = cpHaddocks (ppCommon pp)         , lpForceDirty = boptsForceDirty bopts-        , lpDirtyFiles =-            if not (Set.null allDirtyFiles)-                then let tryStripPrefix y =-                          fromMaybe y (stripPrefix (toFilePath $ lpvRoot lpv) y)-                      in Just $ Set.map tryStripPrefix allDirtyFiles-                else Nothing+        , lpDirtyFiles = dirtyFiles         , lpNewBuildCaches = newBuildCaches-        , lpCabalFile = lpvCabalFP lpv-        , lpDir = lpvRoot lpv+        , lpCabalFile = ppCabalFP pp         , lpWanted = isWanted         , lpComponents = nonLibComponents         -- TODO: refactor this so that it's easier to be sure that these@@ -312,54 +396,8 @@             (exes `Set.difference` packageExes pkg)             (tests `Set.difference` Map.keysSet (packageTests pkg))             (benches `Set.difference` packageBenchmarks pkg)-        , lpLocation = lpvLoc lpv         } --- | Ensure that the flags specified in the stack.yaml file and on the command--- line are used.-checkFlagsUsed :: (MonadThrow m, MonadReader env m, HasBuildConfig env)-               => BuildOptsCLI-               -> [LocalPackage]-               -> Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) -- ^ local deps-               -> Map PackageName snapshot -- ^ snapshot, for error messages-               -> m ()-checkFlagsUsed boptsCli lps extraDeps snapshot = do-    bconfig <- view buildConfigL--        -- Check if flags specified in stack.yaml and the command line are-        -- used, see https://github.com/commercialhaskell/stack/issues/617-    let flags = map (, FSCommandLine) [(k, v) | (Just k, v) <- Map.toList $ boptsCLIFlags boptsCli]-             ++ map (, FSStackYaml) (Map.toList $ bcFlags bconfig)--        localNameMap = Map.fromList $ map (packageName . lpPackage &&& lpPackage) lps-        checkFlagUsed ((name, userFlags), source) =-            case Map.lookup name localNameMap of-                -- Package is not available locally-                Nothing ->-                    if Map.member name extraDeps-                        -- We don't check for flag presence for extra deps-                        then Nothing-                        -- Also not in extra-deps, it's an error-                        else-                            case Map.lookup name snapshot of-                                Nothing -> Just $ UFNoPackage source name-                                Just _ -> Just $ UFSnapshot name-                -- Package exists locally, let's check if the flags are defined-                Just pkg ->-                    let unused = Set.difference (Map.keysSet userFlags) (packageDefinedFlags pkg)-                     in if Set.null unused-                            -- All flags are defined, nothing to do-                            then Nothing-                            -- Error about the undefined flags-                            else Just $ UFFlagsNotDefined source pkg unused--        unusedFlags = mapMaybe checkFlagUsed flags--    unless (null unusedFlags)-        $ throwM-        $ InvalidFlagSpecification-        $ Set.fromList unusedFlags- -- | Compare the current filesystem state to the cached information, and -- determine (1) if the files are dirty, and (2) the new cache values. checkBuildCache :: forall m. (MonadIO m)@@ -378,7 +416,7 @@             fileTimes             oldCache   where-    go :: FilePath -> Maybe ModTime -> Maybe FileCacheInfo -> m (Set FilePath, Map FilePath FileCacheInfo)+    go :: FilePath -> Maybe CTime -> Maybe FileCacheInfo -> m (Set FilePath, Map FilePath FileCacheInfo)     -- Filter out the cabal_macros file to avoid spurious recompilations     go fp _ _ | takeFileName fp == "cabal_macros.h" = return (Set.empty, Map.empty)     -- Common case where it's in the cache and on the filesystem.@@ -401,7 +439,7 @@ -- | Returns entries to add to the build cache for any newly found unlisted modules addUnlistedToBuildCache     :: HasEnvConfig env-    => ModTime+    => CTime     -> Package     -> Path Abs File     -> Set NamedComponent@@ -442,25 +480,25 @@     let necessaryComponents = Set.insert CLib $ Set.filter isCInternalLib (M.keysSet components')         components = necessaryComponents `Set.union` nonLibComponents         componentsFiles =-            M.map (\files -> Set.union otherFiles (Set.map dotCabalGetPath files)) $-                M.filterWithKey (\component _ -> component `Set.member` components) compFiles+            M.map (\files -> Set.union otherFiles (Set.map dotCabalGetPath $ Set.fromList files)) $+                M.filterWithKey (\component _ -> component `elem` components) compFiles     return (componentsFiles, warnings)  -- | Get file modification time, if it exists.-getModTimeMaybe :: MonadIO m => FilePath -> m (Maybe ModTime)+getModTimeMaybe :: MonadIO m => FilePath -> m (Maybe CTime) getModTimeMaybe fp =     liftIO         (catch              (liftM-                  (Just . modTime)-                  (D.getModificationTime fp))+                  (Just . modificationTime)+                  (getFileStatus fp))              (\e ->                    if isDoesNotExistError e                        then return Nothing                        else throwM e))  -- | Create FileCacheInfo for a file.-calcFci :: MonadIO m => ModTime -> FilePath -> m FileCacheInfo+calcFci :: MonadIO m => CTime -> FilePath -> m FileCacheInfo calcFci modTime' fp = liftIO $     withSourceFile fp $ \src -> do         (size, digest) <- runConduit $ src .| getZipSink@@ -468,39 +506,29 @@                 <$> ZipSink (CL.fold                     (\x y -> x + fromIntegral (S.length y))                     0)-                <*> ZipSink sinkHash)+                <*> ZipSink SHA256.sinkHash)         return FileCacheInfo             { fciModTime = modTime'-            , fciSize = size-            , fciHash = Mem.convert (digest :: Digest SHA256)+            , fciSize = FileSize size+            , fciHash = digest             } -checkComponentsBuildable :: MonadThrow m => [LocalPackage] -> m ()-checkComponentsBuildable lps =-    unless (null unbuildable) $ throwM $ SomeTargetsNotBuildable unbuildable-  where-    unbuildable =-        [ (packageName (lpPackage lp), c)-        | lp <- lps-        , c <- Set.toList (lpUnbuildable lp)-        ]- -- | Get 'PackageConfig' for package given its name.-getPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env)-  => BuildOptsCLI-  -> PackageName-  -> Bool-  -> Bool-  -> m PackageConfig-getPackageConfig boptsCli name isTarget isLocal = do-  bconfig <- view buildConfigL+getPackageConfig+  :: (HasBuildConfig env, HasSourceMap env)+  => Map FlagName Bool+  -> [Text] -- ^ GHC options+  -> [Text] -- ^ cabal config opts+  -> RIO env PackageConfig+getPackageConfig flags ghcOptions cabalConfigOpts = do   platform <- view platformL   compilerVersion <- view actualCompilerVersionL   return PackageConfig     { packageConfigEnableTests = False     , packageConfigEnableBenchmarks = False-    , packageConfigFlags = getLocalFlags bconfig boptsCli name-    , packageConfigGhcOptions = getGhcOptions bconfig boptsCli name isTarget isLocal+    , packageConfigFlags = flags+    , packageConfigGhcOptions = ghcOptions+    , packageConfigCabalConfigOpts = cabalConfigOpts     , packageConfigCompilerVersion = compilerVersion     , packageConfigPlatform = platform     }
src/Stack/Build/Target.hs view
@@ -71,26 +71,18 @@     ) where  import           Stack.Prelude-import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T-import           Distribution.PackageDescription (GenericPackageDescription, package, packageDescription) import           Path import           Path.Extra (rejectMissingDir) import           Path.IO-import           Stack.Config (getLocalPackages)-import           Stack.PackageIndex-import           Stack.PackageLocation-import           Stack.Snapshot (calculatePackagePromotion)+import           RIO.Process (HasProcessContext)+import           Stack.SourceMap import           Stack.Types.Config import           Stack.Types.NamedComponent-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Version import           Stack.Types.Build-import           Stack.Types.BuildPlan-import           Stack.Types.GhcPkgId+import           Stack.Types.SourceMap  -- | Do we need any targets? For example, `stack build` will fail if -- no targets are provided.@@ -103,13 +95,13 @@ -- | Raw target information passed on the command line. newtype RawInput = RawInput { unRawInput :: Text } -getRawInput :: BuildOptsCLI -> Map PackageName LocalPackageView -> ([Text], [RawInput])+getRawInput :: BuildOptsCLI -> Map PackageName ProjectPackage -> ([Text], [RawInput]) getRawInput boptscli locals =     let textTargets' = boptsCLITargets boptscli         textTargets =             -- Handle the no targets case, which means we pass in the names of all project packages             if null textTargets'-                then map packageNameText (Map.keys locals)+                then map (T.pack . packageNameString) (Map.keys locals)                 else textTargets'      in (textTargets', map RawInput textTargets) @@ -144,7 +136,7 @@ -- | Same as @parseRawTarget@, but also takes directories into account. parseRawTargetDirs :: MonadIO m                    => Path Abs Dir -- ^ current directory-                   -> Map PackageName LocalPackageView+                   -> Map PackageName ProjectPackage                    -> RawInput -- ^ raw target information from the commandline                    -> m (Either Text [(RawInput, RawTarget)]) parseRawTargetDirs root locals ri =@@ -162,8 +154,8 @@                             t                         names -> return $ Right $ map ((ri, ) . RTPackage) names   where-    childOf dir (name, lpv) =-        if dir == lpvRoot lpv || isProperPrefixOf dir (lpvRoot lpv)+    childOf dir (name, pp) =+        if dir == ppRoot pp || isProperPrefixOf dir (ppRoot pp)             then Just name             else Nothing @@ -173,8 +165,8 @@ -- directory. parseRawTarget :: Text -> Maybe RawTarget parseRawTarget t =-        (RTPackageIdentifier <$> parsePackageIdentifier t)-    <|> (RTPackage <$> parsePackageNameFromString s)+        (RTPackageIdentifier <$> parsePackageIdentifier s)+    <|> (RTPackage <$> parsePackageName s)     <|> (RTComponent <$> T.stripPrefix ":" t)     <|> parsePackageComponent   where@@ -183,13 +175,13 @@     parsePackageComponent =         case T.splitOn ":" t of             [pname, "lib"]-                | Just pname' <- parsePackageNameFromString (T.unpack pname) ->+                | Just pname' <- parsePackageName (T.unpack pname) ->                     Just $ RTPackageComponent pname' $ ResolvedComponent CLib             [pname, cname]-                | Just pname' <- parsePackageNameFromString (T.unpack pname) ->+                | Just pname' <- parsePackageName (T.unpack pname) ->                     Just $ RTPackageComponent pname' $ UnresolvedComponent cname             [pname, typ, cname]-                | Just pname' <- parsePackageNameFromString (T.unpack pname)+                | Just pname' <- parsePackageName (T.unpack pname)                 , Just wrapper <- parseCompType typ ->                     Just $ RTPackageComponent pname' $ ResolvedComponent $ wrapper cname             _ -> Nothing@@ -210,24 +202,25 @@   , rrRaw :: !RawInput   , rrComponent :: !(Maybe NamedComponent)   -- ^ Was a concrete component specified?-  , rrAddedDep :: !(Maybe Version)+  , rrAddedDep :: !(Maybe PackageLocationImmutable)   -- ^ Only if we're adding this as a dependency   , rrPackageType :: !PackageType   }  -- | Convert a 'RawTarget' into a 'ResolveResult' (see description on -- the module).-resolveRawTarget-  :: forall env. HasConfig env-  => Map PackageName (LoadedPackageInfo GhcPkgId) -- ^ globals-  -> Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) -- ^ snapshot-  -> Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath) -- ^ local deps-  -> Map PackageName LocalPackageView -- ^ project packages-  -> (RawInput, RawTarget)-  -> RIO env (Either Text ResolveResult)-resolveRawTarget globals snap deps locals (ri, rt) =-    go rt+resolveRawTarget ::+       (HasLogFunc env, HasPantryConfig env, HasProcessContext env)+    => SMActual GlobalPackage+    -> Map PackageName PackageLocation+    -> (RawInput, RawTarget)+    -> RIO env (Either Text ResolveResult)+resolveRawTarget sma allLocs (ri, rt) =+  go rt   where+    locals = smaProject sma+    deps = smaDeps sma+    globals = smaGlobal sma     -- Helper function: check if a 'NamedComponent' matches the given 'ComponentName'     isCompNamed :: ComponentName -> NamedComponent -> Bool     isCompNamed _ CLib = False@@ -236,21 +229,22 @@     isCompNamed t1 (CTest t2) = t1 == t2     isCompNamed t1 (CBench t2) = t1 == t2 -    go (RTComponent cname) = return $+    go (RTComponent cname) = do         -- Associated list from component name to package that defines         -- it. We use an assoc list and not a Map so we can detect         -- duplicates.-        let allPairs = concatMap-                (\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv)-                (Map.toList locals)-         in case filter (isCompNamed cname . snd) allPairs of+        allPairs <- fmap concat $ flip Map.traverseWithKey locals+          $ \name pp -> do+              comps <- ppComponents pp+              pure $ map (name, ) $ Set.toList comps+        pure $ case filter (isCompNamed cname . snd) allPairs of                 [] -> Left $ cname `T.append` " doesn't seem to be a local target. Run 'stack ide targets' for a list of available targets"                 [(name, comp)] -> Right ResolveResult                   { rrName = name                   , rrRaw = ri                   , rrComponent = Just comp                   , rrAddedDep = Nothing-                  , rrPackageType = ProjectPackage+                  , rrPackageType = PTProject                   }                 matches -> Left $ T.concat                     [ "Ambiugous component name "@@ -258,18 +252,19 @@                     , ", matches: "                     , T.pack $ show matches                     ]-    go (RTPackageComponent name ucomp) = return $+    go (RTPackageComponent name ucomp) =         case Map.lookup name locals of-            Nothing -> Left $ T.pack $ "Unknown local package: " ++ packageNameString name-            Just lpv ->-                case ucomp of+            Nothing -> pure $ Left $ T.pack $ "Unknown local package: " ++ packageNameString name+            Just pp -> do+                comps <- ppComponents pp+                pure $ case ucomp of                     ResolvedComponent comp-                        | comp `Set.member` lpvComponents lpv -> Right ResolveResult+                        | comp `Set.member` comps -> Right ResolveResult                             { rrName = name                             , rrRaw = ri                             , rrComponent = Just comp                             , rrAddedDep = Nothing-                            , rrPackageType = ProjectPackage+                            , rrPackageType = PTProject                             }                         | otherwise -> Left $ T.pack $ concat                             [ "Component "@@ -278,7 +273,7 @@                             , packageNameString name                             ]                     UnresolvedComponent comp ->-                        case filter (isCompNamed comp) $ Set.toList $ lpvComponents lpv of+                        case filter (isCompNamed comp) $ Set.toList comps of                             [] -> Left $ T.concat                                 [ "Component "                                 , comp@@ -290,7 +285,7 @@                               , rrRaw = ri                               , rrComponent = Just x                               , rrAddedDep = Nothing-                              , rrPackageType = ProjectPackage+                              , rrPackageType = PTProject                               }                             matches -> Left $ T.concat                                 [ "Ambiguous component name "@@ -307,123 +302,110 @@           , rrRaw = ri           , rrComponent = Nothing           , rrAddedDep = Nothing-          , rrPackageType = ProjectPackage-          }-      | Map.member name deps ||-        Map.member name snap ||-        Map.member name globals = return $ Right ResolveResult-          { rrName = name-          , rrRaw = ri-          , rrComponent = Nothing-          , rrAddedDep = Nothing-          , rrPackageType = Dependency+          , rrPackageType = PTProject           }-      | otherwise = do-          mversion <- getLatestVersion name-          return $ case mversion of-            -- This is actually an error case. We _could_ return a-            -- Left value here, but it turns out to be better to defer-            -- this until the ConstructPlan phase, and let it complain-            -- about the missing package so that we get more errors-            -- together, plus the fancy colored output from that-            -- module.-            Nothing -> Right ResolveResult-              { rrName = name-              , rrRaw = ri-              , rrComponent = Nothing-              , rrAddedDep = Nothing-              , rrPackageType = Dependency-              }-            Just version -> Right ResolveResult-              { rrName = name-              , rrRaw = ri-              , rrComponent = Nothing-              , rrAddedDep = Just version-              , rrPackageType = Dependency-              }-      where-        getLatestVersion pn =-            fmap fst . Set.maxView . Set.fromList . HashMap.keys <$> getPackageVersions pn+      | Map.member name deps =+          pure $ deferToConstructPlan name+      | Just gp <- Map.lookup name globals =+          case gp of+              GlobalPackage _ -> pure $ deferToConstructPlan name+              ReplacedGlobalPackage _ -> hackageLatest name+      | otherwise = hackageLatest name +    -- Note that we use getLatestHackageRevision below, even though it's+    -- non-reproducible, to avoid user confusion. In any event,+    -- reproducible builds should be done by updating your config+    -- files!+     go (RTPackageIdentifier ident@(PackageIdentifier name version))       | Map.member name locals = return $ Left $ T.concat-            [ packageNameText name+            [ tshow (packageNameString name)             , " target has a specific version number, but it is a local package."             , "\nTo avoid confusion, we will not install the specified version or build the local one."             , "\nTo build the local package, specify the target without an explicit version."             ]-      | otherwise = return $+      | otherwise =           case Map.lookup name allLocs of             -- Installing it from the package index, so we're cool             -- with overriding it if necessary-            Just (PLIndex (PackageIdentifierRevision (PackageIdentifier _name versionLoc) _mcfi)) -> Right ResolveResult-                  { rrName = name-                  , rrRaw = ri-                  , rrComponent = Nothing-                  , rrAddedDep =-                      if version == versionLoc-                        -- But no need to override anyway, this is already the-                        -- version we have-                        then Nothing-                        -- OK, we'll override it-                        else Just version-                  , rrPackageType = Dependency-                  }+            Just (PLImmutable (PLIHackage (PackageIdentifier _name versionLoc) _cfKey _treeKey)) ->+              if version == versionLoc+              then pure $ deferToConstructPlan name+              else hackageLatestRevision name version             -- The package was coming from something besides the             -- index, so refuse to do the override-            Just (PLOther loc') -> Left $ T.concat+            Just loc' -> pure $ Left $ T.concat               [ "Package with identifier was targeted on the command line: "-              , packageIdentifierText ident+              , T.pack $ packageIdentifierString ident               , ", but it was specified from a non-index location: "               , T.pack $ show loc'               , ".\nRecommendation: add the correctly desired version to extra-deps."               ]-            -- Not present at all, so add it-            Nothing -> Right ResolveResult+            -- Not present at all, add it from Hackage+            Nothing -> do+              mrev <- getLatestHackageRevision YesRequireHackageIndex name version+              pure $ case mrev of+                Nothing -> deferToConstructPlan name+                Just (_rev, cfKey, treeKey) -> Right ResolveResult+                  { rrName = name+                  , rrRaw = ri+                  , rrComponent = Nothing+                  , rrAddedDep = Just $ PLIHackage (PackageIdentifier name version) cfKey treeKey+                  , rrPackageType = PTDependency+                  }++    hackageLatest name = do+        mloc <- getLatestHackageLocation YesRequireHackageIndex name UsePreferredVersions+        pure $ case mloc of+          Nothing -> deferToConstructPlan name+          Just loc -> do+            Right ResolveResult+                  { rrName = name+                  , rrRaw = ri+                  , rrComponent = Nothing+                  , rrAddedDep = Just loc+                  , rrPackageType = PTDependency+                  }++    hackageLatestRevision name version = do+        mrev <- getLatestHackageRevision YesRequireHackageIndex name version+        pure $ case mrev of+          Nothing -> deferToConstructPlan name+          Just (_rev, cfKey, treeKey) -> Right ResolveResult+            { rrName = name+            , rrRaw = ri+            , rrComponent = Nothing+            , rrAddedDep = Just $ PLIHackage (PackageIdentifier name version) cfKey treeKey+            , rrPackageType = PTDependency+            }++    -- This is actually an error case. We _could_ return a+    -- Left value here, but it turns out to be better to defer+    -- this until the ConstructPlan phase, and let it complain+    -- about the missing package so that we get more errors+    -- together, plus the fancy colored output from that+    -- module.+    deferToConstructPlan name = Right ResolveResult               { rrName = name               , rrRaw = ri               , rrComponent = Nothing-              , rrAddedDep = Just version-              , rrPackageType = Dependency+              , rrAddedDep = Nothing+              , rrPackageType = PTDependency               }--      where-        allLocs :: Map PackageName (PackageLocationIndex FilePath)-        allLocs = Map.unions-          [ Map.mapWithKey-              (\name' lpi -> PLIndex $ PackageIdentifierRevision-                  (PackageIdentifier name' (lpiVersion lpi))-                  CFILatest)-              globals-          , Map.map lpiLocation snap-          , Map.map snd deps-          ]- --------------------------------------------------------------------------------- -- Combine the ResolveResults --------------------------------------------------------------------------------- --- | How a package is intended to be built-data Target-  = TargetAll !PackageType-  -- ^ Build all of the default components.-  | TargetComps !(Set NamedComponent)-  -- ^ Only build specific components--data PackageType = ProjectPackage | Dependency-  deriving (Eq, Show)- combineResolveResults   :: forall env. HasLogFunc env   => [ResolveResult]-  -> RIO env ([Text], Map PackageName Target, Map PackageName (PackageLocationIndex FilePath))+  -> RIO env ([Text], Map PackageName Target, Map PackageName PackageLocationImmutable) combineResolveResults results = do     addedDeps <- fmap Map.unions $ forM results $ \result ->       case rrAddedDep result of         Nothing -> return Map.empty-        Just version -> do-          let ident = PackageIdentifier (rrName result) version-          return $ Map.singleton (rrName result) $ PLIndex $ PackageIdentifierRevision ident CFILatest+        Just pl -> do+          return $ Map.singleton (rrName result) pl      let m0 = Map.unionsWith (++) $ map (\rr -> Map.singleton (rrName rr) [rr]) results         (errs, ms) = partitionEithers $ flip map (Map.toList m0) $ \(name, rrs) ->@@ -437,7 +419,7 @@                   | all isJust mcomps -> Right $ Map.singleton name $ TargetComps $ Set.fromList $ catMaybes mcomps                   | otherwise -> Left $ T.concat                       [ "The package "-                      , packageNameText name+                      , T.pack $ packageNameString name                       , " was specified in multiple, incompatible ways: "                       , T.unwords $ map (unRawInput . rrRaw) rrs                       ]@@ -448,32 +430,26 @@ -- OK, let's do it! --------------------------------------------------------------------------------- -parseTargets-    :: HasEnvConfig env+parseTargets :: HasBuildConfig env     => NeedTargets+    -> Bool     -> BuildOptsCLI-    -> RIO env-         ( LoadedSnapshot -- upgraded snapshot, with some packages possibly moved to local-         , Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) -- all local deps-         , Map PackageName Target-         )-parseTargets needTargets boptscli = do+    -> SMActual GlobalPackage+    -> RIO env SMTargets+parseTargets needTargets haddockDeps boptscli smActual = do   logDebug "Parsing the targets"   bconfig <- view buildConfigL-  ls0 <- view loadedSnapshotL   workingDir <- getCurrentDir-  lp <- getLocalPackages-  let locals = lpProject lp-      deps = lpDependencies lp-      globals = lsGlobals ls0-      snap = lsPackages ls0-      (textTargets', rawInput) = getRawInput boptscli locals+  locals <- view $ buildConfigL.to (smwProject . bcSMWanted)+  let (textTargets', rawInput) = getRawInput boptscli locals    (errs1, concat -> rawTargets) <- fmap partitionEithers $ forM rawInput $-    parseRawTargetDirs workingDir (lpProject lp)+    parseRawTargetDirs workingDir locals +  let depLocs = Map.map dpLocation $ smaDeps smActual+   (errs2, resolveResults) <- fmap partitionEithers $ forM rawTargets $-    resolveRawTarget globals snap deps locals+    resolveRawTarget smActual depLocs    (errs3, targets, addedDeps) <- combineResolveResults resolveResults @@ -492,67 +468,15 @@       | otherwise -> throwIO $ TargetParseException           ["The specified targets matched no packages"] -  root <- view projectRootL--  let dropMaybeKey (Nothing, _) = Map.empty-      dropMaybeKey (Just key, value) = Map.singleton key value-      flags = Map.unionWith Map.union-        (Map.unions (map dropMaybeKey (Map.toList (boptsCLIFlags boptscli))))-        (bcFlags bconfig)-      hides = Map.empty -- not supported to add hidden packages--      -- We promote packages to the local database if the GHC options-      -- are added to them by name. See:-      -- https://github.com/commercialhaskell/stack/issues/849#issuecomment-320892095.-      ---      -- GHC options applied to all packages are handled by getGhcOptions.-      options = configGhcOptionsByName (bcConfig bconfig)--      drops = Set.empty -- not supported to add drops--  (globals', snapshots, locals') <- do-    addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do-      gpd <- parseSingleCabalFileIndex root loc-      return (name, (gpd, loc, Nothing))--    -- Calculate a list of all of the locals, based on the project-    -- packages, local dependencies, and added deps found from the-    -- command line-    let allLocals :: Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath, Maybe LocalPackageView)-        allLocals = Map.unions-          [ -- project packages-            Map.map-              (\lpv -> (lpvGPD lpv, PLOther $ lpvLoc lpv, Just lpv))-              (lpProject lp)-          , -- added deps take precendence over local deps-            addedDeps'-          , -- added deps take precendence over local deps-            Map.map-              (\(gpd, loc) -> (gpd, loc, Nothing))-              (lpDependencies lp)-          ]--    calculatePackagePromotion-      root ls0 (Map.elems allLocals)-      flags hides options drops--  let ls = LoadedSnapshot-        { lsCompilerVersion = lsCompilerVersion ls0-        , lsGlobals = globals'-        , lsPackages = snapshots-        }--      localDeps = Map.fromList $ flip mapMaybe (Map.toList locals') $ \(name, lpi) ->-        -- We want to ignore any project packages, but grab the local-        -- deps and upgraded snapshot deps-        case lpiLocation lpi of-          (_, Just (Just _localPackageView)) -> Nothing -- project package-          (loc, _) -> Just (name, lpi { lpiLocation = loc }) -- upgraded or local dep--  return (ls, localDeps, targets)+  addedDeps' <- mapM (additionalDepPackage haddockDeps . PLImmutable) addedDeps -gpdVersion :: GenericPackageDescription -> Version-gpdVersion gpd =-    version+  return SMTargets+    { smtTargets = targets+    , smtDeps = addedDeps'+    }   where-    PackageIdentifier _ version = fromCabalPackageIdentifier $ package $ packageDescription gpd+    bcImplicitGlobal bconfig =+      case configProject $ bcConfig bconfig of+        PCProject _ -> False+        PCGlobalProject -> True+        PCNoProject _ -> False
src/Stack/BuildPlan.hs view
@@ -16,8 +16,6 @@     , checkSnapBuildPlan     , DepError(..)     , DepErrors-    , gpdPackageDeps-    , gpdPackages     , removeSrcPkgDefaultFlags     , selectBestSnapshot     , showItems@@ -25,12 +23,11 @@  import           Stack.Prelude hiding (Display (..)) import qualified Data.Foldable as F-import qualified Data.HashSet as HashSet+import qualified Data.Set as Set import           Data.List (intercalate) import           Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map-import qualified Data.Set as Set import qualified Data.Text as T import qualified Distribution.Package as C import           Distribution.PackageDescription (GenericPackageDescription,@@ -39,15 +36,13 @@ import qualified Distribution.PackageDescription as C import           Distribution.System (Platform) import           Distribution.Text (display)+import           Distribution.Types.UnqualComponentName (unUnqualComponentName) import qualified Distribution.Version as C import qualified RIO import           Stack.Constants import           Stack.Package-import           Stack.Snapshot-import           Stack.Types.BuildPlan-import           Stack.Types.FlagName-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName+import           Stack.SourceMap+import           Stack.Types.SourceMap import           Stack.Types.Version import           Stack.Types.Config import           Stack.Types.Compiler@@ -127,7 +122,7 @@                 [ packageNameString dep                 , " (used by "                 , intercalate ", "-                    $ map (packageNameString . packageIdentifierName)+                    $ map (packageNameString . pkgName)                     $ Set.toList users                 , ")"                 ]@@ -142,22 +137,26 @@         ", because no 'compiler' or 'resolver' is specified."  gpdPackages :: [GenericPackageDescription] -> Map PackageName Version-gpdPackages gpds = Map.fromList $-            map (fromCabalIdent . C.package . C.packageDescription) gpds+gpdPackages = Map.fromList . map (toPair . C.package . C.packageDescription)     where-        fromCabalIdent (C.PackageIdentifier name version) =-            (fromCabalPackageName name, fromCabalVersion version)+        toPair (C.PackageIdentifier name version) = (name, version)  gpdPackageDeps     :: GenericPackageDescription-    -> CompilerVersion 'CVActual+    -> ActualCompiler     -> Platform     -> Map FlagName Bool     -> Map PackageName VersionRange-gpdPackageDeps gpd cv platform flags =-    Map.filterWithKey (const . (/= name)) (packageDependencies pkgConfig pkgDesc)+gpdPackageDeps gpd ac platform flags =+    Map.filterWithKey (const . not . isLocalLibrary) (packageDependencies pkgConfig pkgDesc)     where+        isLocalLibrary name' = name' == name || name' `Set.member` subs+         name = gpdPackageName gpd+        subs = Set.fromList+             $ map (C.mkPackageName . unUnqualComponentName . fst)+             $ C.condSubLibraries gpd+         -- Since tests and benchmarks are both enabled, doesn't matter         -- if we choose modified or unmodified         pkgDesc = pdpModifiedBuildable $ resolvePackageDescription pkgConfig gpd@@ -166,7 +165,8 @@             , packageConfigEnableBenchmarks = True             , packageConfigFlags = flags             , packageConfigGhcOptions = []-            , packageConfigCompilerVersion = cv+            , packageConfigCabalConfigOpts = []+            , packageConfigCompilerVersion = ac             , packageConfigPlatform = platform             } @@ -188,10 +188,9 @@             let tuples = map getDefault (C.genPackageFlags gpd)             in Map.singleton (gpdPackageName gpd) (Map.fromList tuples) -        flagName' = fromCabalFlagName . C.flagName         getDefault f-            | C.flagDefault f = (flagName' f, True)-            | otherwise       = (flagName' f, False)+            | C.flagDefault f = (C.flagName f, True)+            | otherwise       = (C.flagName f, False)  -- | Find the set of @FlagName@s necessary to get the given -- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will@@ -199,7 +198,7 @@ -- Returns the plan which produces least number of dep errors selectPackageBuildPlan     :: Platform-    -> CompilerVersion 'CVActual+    -> ActualCompiler     -> Map PackageName Version     -> GenericPackageDescription     -> (Map PackageName (Map FlagName Bool), DepErrors)@@ -232,13 +231,13 @@             | flagManual f = (fname, flagDefault f) :| []             | flagDefault f = (fname, True) :| [(fname, False)]             | otherwise = (fname, False) :| [(fname, True)]-          where fname = (fromCabalFlagName . flagName) f+          where fname = flagName f  -- | Check whether with the given set of flags a package's dependency -- constraints can be satisfied against a given build plan or pool of packages. checkPackageBuildPlan     :: Platform-    -> CompilerVersion 'CVActual+    -> ActualCompiler     -> Map PackageName Version     -> Map FlagName Bool     -> GenericPackageDescription@@ -292,7 +291,7 @@ -- will be chosen automatically. checkBundleBuildPlan     :: Platform-    -> CompilerVersion 'CVActual+    -> ActualCompiler     -> Map PackageName Version     -> Maybe (Map PackageName (Map FlagName Bool))     -> [GenericPackageDescription]@@ -316,7 +315,7 @@       BuildPlanCheckOk      (Map PackageName (Map FlagName Bool))     | BuildPlanCheckPartial (Map PackageName (Map FlagName Bool)) DepErrors     | BuildPlanCheckFail    (Map PackageName (Map FlagName Bool)) DepErrors-                            (CompilerVersion 'CVActual)+                            ActualCompiler  -- | Compare 'BuildPlanCheck', where GT means a better plan. compareBuildPlanCheck :: BuildPlanCheck -> BuildPlanCheck -> Ordering@@ -342,21 +341,25 @@ -- the packages. checkSnapBuildPlan     :: (HasConfig env, HasGHCVariant env)-    => Path Abs Dir -- ^ project root, used for checking out necessary files-    -> [GenericPackageDescription]+    => [ResolvedPath Dir]     -> Maybe (Map PackageName (Map FlagName Bool))-    -> SnapshotDef-    -> Maybe (CompilerVersion 'CVActual)+    -> SnapshotCandidate env     -> RIO env BuildPlanCheck-checkSnapBuildPlan root gpds flags snapshotDef mactualCompiler = do+checkSnapBuildPlan pkgDirs flags snapCandidate = do     platform <- view platformL-    rs <- loadSnapshot mactualCompiler root snapshotDef+    sma <- snapCandidate pkgDirs+    gpds <- liftIO $ forM (Map.elems $ smaProject sma) (cpGPD . ppCommon)      let-        compiler = lsCompilerVersion rs+        compiler = smaCompiler sma+        globalVersion (GlobalPackageVersion v) = v+        depVersion dep | PLImmutable loc <- dpLocation dep =+                           Just $ packageLocationVersion loc+                       | otherwise =+                           Nothing         snapPkgs = Map.union-          (lpiVersion <$> lsGlobals rs)-          (lpiVersion <$> lsPackages rs)+          (Map.mapMaybe depVersion $ smaDeps sma)+          (Map.map globalVersion $ smaGlobal sma)         (f, errs) = checkBundleBuildPlan platform compiler snapPkgs flags gpds         cerrs = compilerErrors compiler errs @@ -372,64 +375,60 @@             -- FIXME not sure how to handle ghcjs boot packages             | otherwise = Map.empty -        isGhcWiredIn p _ = p `HashSet.member` wiredInPackages+        isGhcWiredIn p _ = p `Set.member` wiredInPackages         ghcErrors = Map.filterWithKey isGhcWiredIn  -- | Find a snapshot and set of flags that is compatible with and matches as -- best as possible with the given 'GenericPackageDescription's. selectBestSnapshot     :: (HasConfig env, HasGHCVariant env)-    => Path Abs Dir -- ^ project root, used for checking out necessary files-    -> [GenericPackageDescription]+    => [ResolvedPath Dir]     -> NonEmpty SnapName-    -> RIO env (SnapshotDef, BuildPlanCheck)-selectBestSnapshot root gpds snaps = do+    -> RIO env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)+selectBestSnapshot pkgDirs snaps = do     logInfo $ "Selecting the best among "                <> displayShow (NonEmpty.length snaps)                <> " snapshots...\n"-    F.foldr1 go (NonEmpty.map (getResult <=< loadResolver . ResolverStackage) snaps)+    let resolverStackage (LTS x y) = ltsSnapshotLocation x y+        resolverStackage (Nightly d) = nightlySnapshotLocation d+    F.foldr1 go (NonEmpty.map (getResult . resolverStackage) snaps)     where         go mold mnew = do-            old@(_snap, bpc) <- mold+            old@(_snap, _loc, bpc) <- mold             case bpc of                 BuildPlanCheckOk {} -> return old                 _ -> fmap (betterSnap old) mnew -        getResult snap = do-            result <- checkSnapBuildPlan root gpds Nothing snap-              -- We know that we're only dealing with ResolverStackage-              -- here, where we can rely on the global package hints.-              -- Therefore, we don't use an actual compiler. For more-              -- info, see comments on-              -- Stack.Solver.checkSnapBuildPlanActual.-              Nothing-            reportResult result snap-            return (snap, result)+        getResult loc = do+            candidate <- loadProjectSnapshotCandidate loc NoPrintWarnings False+            result <- checkSnapBuildPlan pkgDirs Nothing candidate+            reportResult result loc+            return (candidate, loc, result) -        betterSnap (s1, r1) (s2, r2)-          | compareBuildPlanCheck r1 r2 /= LT = (s1, r1)-          | otherwise = (s2, r2)+        betterSnap (s1, l1, r1) (s2, l2, r2)+          | compareBuildPlanCheck r1 r2 /= LT = (s1, l1, r1)+          | otherwise = (s2, l2, r2) -        reportResult BuildPlanCheckOk {} snap = do-            logInfo $ "* Matches " <> RIO.display (sdResolverName snap)+        reportResult BuildPlanCheckOk {} loc = do+            logInfo $ "* Matches " <> RIO.display loc             logInfo "" -        reportResult r@BuildPlanCheckPartial {} snap = do-            logWarn $ "* Partially matches " <> RIO.display (sdResolverName snap)+        reportResult r@BuildPlanCheckPartial {} loc = do+            logWarn $ "* Partially matches " <> RIO.display loc             logWarn $ RIO.display $ indent $ T.pack $ show r -        reportResult r@BuildPlanCheckFail {} snap = do-            logWarn $ "* Rejected " <> RIO.display (sdResolverName snap)+        reportResult r@BuildPlanCheckFail {} loc = do+            logWarn $ "* Rejected " <> RIO.display loc             logWarn $ RIO.display $ indent $ T.pack $ show r          indent t = T.unlines $ fmap ("    " <>) (T.lines t) -showItems :: Show a => [a] -> Text+showItems :: [String] -> Text showItems items = T.concat (map formatItem items)     where         formatItem item = T.concat             [ "    - "-            , T.pack $ show item+            , T.pack item             , "\n"             ] @@ -449,12 +448,12 @@         formatFlags (f, v) = show f ++ " = " ++ show v  showMapPackages :: Map PackageName a -> Text-showMapPackages mp = showItems $ Map.keys mp+showMapPackages mp = showItems $ map packageNameString $ Map.keys mp  showCompilerErrors     :: Map PackageName (Map FlagName Bool)     -> DepErrors-    -> CompilerVersion 'CVActual+    -> ActualCompiler     -> Text showCompilerErrors flags errs compiler =     T.concat
src/Stack/Clean.hs view
@@ -8,6 +8,7 @@ module Stack.Clean     (clean     ,CleanOpts(..)+    ,CleanCommand(..)     ,StackCleanException(..)     ) where @@ -15,53 +16,58 @@ import           Data.List ((\\),intercalate) import qualified Data.Map.Strict as Map import           Path.IO (ignoringAbsence, removeDirRecur)-import           Stack.Config (getLocalPackages)-import           Stack.Constants.Config (distDirFromDir, workDirFromDir)-import           Stack.Types.PackageName+import           Stack.Constants.Config (rootDistDirFromDir, workDirFromDir) import           Stack.Types.Config-import           System.Exit (exitFailure)+import           Stack.Types.SourceMap  -- | Deletes build artifacts in the current project. -- -- Throws 'StackCleanException'.-clean :: HasEnvConfig env => CleanOpts -> RIO env ()+clean :: HasBuildConfig env => CleanOpts -> RIO env () clean cleanOpts = do-    failures <- mapM cleanDir =<< dirsToDelete cleanOpts-    when (or failures) $ liftIO System.Exit.exitFailure+    toDelete <- dirsToDelete cleanOpts+    logDebug $ "Need to delete: " <> fromString (show (map toFilePath toDelete))+    failures <- mapM cleanDir toDelete+    when (or failures) exitFailure   where-    cleanDir dir =+    cleanDir dir = do+      logDebug $ "Deleting directory: " <> fromString (toFilePath dir)       liftIO (ignoringAbsence (removeDirRecur dir) >> return False) `catchAny` \ex -> do         logError $ "Exception while recursively deleting " <> fromString (toFilePath dir) <> "\n" <> displayShow ex         logError "Perhaps you do not have permission to delete these files or they are in use?"         return True -dirsToDelete :: HasEnvConfig env => CleanOpts -> RIO env [Path Abs Dir]+dirsToDelete :: HasBuildConfig env => CleanOpts -> RIO env [Path Abs Dir] dirsToDelete cleanOpts = do-    packages <- getLocalPackages+    packages <- view $ buildConfigL.to (smwProject . bcSMWanted)     case cleanOpts of         CleanShallow [] ->             -- Filter out packages listed as extra-deps-            mapM (distDirFromDir . lpvRoot) $ Map.elems $ lpProject packages+            mapM (rootDistDirFromDir . ppRoot) $ Map.elems packages         CleanShallow targets -> do-            let localPkgViews = lpProject packages-                localPkgNames = Map.keys localPkgViews-                getPkgDir pkgName = fmap lpvRoot (Map.lookup pkgName localPkgViews)+            let localPkgNames = Map.keys packages+                getPkgDir pkgName' = fmap ppRoot (Map.lookup pkgName' packages)             case targets \\ localPkgNames of-                [] -> mapM distDirFromDir (mapMaybe getPkgDir targets)+                [] -> mapM rootDistDirFromDir (mapMaybe getPkgDir targets)                 xs -> throwM (NonLocalPackages xs)         CleanFull -> do-            pkgWorkDirs <- mapM (workDirFromDir . lpvRoot) $ Map.elems $ lpProject packages+            pkgWorkDirs <- mapM (workDirFromDir . ppRoot) $ Map.elems packages             projectWorkDir <- getProjectWorkDir             return (projectWorkDir : pkgWorkDirs)  -- | Options for @stack clean@. data CleanOpts     = CleanShallow [PackageName]-    -- ^ Delete the "dist directories" as defined in 'Stack.Constants.distRelativeDir'+    -- ^ Delete the "dist directories" as defined in 'Stack.Constants.Config.distRelativeDir'     -- for the given local packages. If no packages are given, all project packages     -- should be cleaned.     | CleanFull     -- ^ Delete all work directories in the project.++-- | Clean commands+data CleanCommand+    = Clean+    | Purge  -- | Exceptions during cleanup. newtype StackCleanException
src/Stack/Config.hs view
@@ -1,21 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TupleSections #-}  -- | The general Stack configuration that starts everything off. This should -- be smart to falback if there is no stack.yaml, instead relying on@@ -28,15 +18,10 @@ -- probably default to behaving like cabal, possibly with spitting out -- a warning that "you should run `stk init` to make things better". module Stack.Config-  (MiniConfig-  ,loadConfig-  ,loadConfigMaybeProject-  ,loadMiniConfig+  (loadConfig   ,loadConfigYaml   ,packagesParser-  ,getLocalPackages   ,getImplicitGlobalProjectDir-  ,getStackYaml   ,getSnapshots   ,makeConcreteResolver   ,checkOwnership@@ -44,27 +29,28 @@   ,getInNixShell   ,defaultConfigYaml   ,getProjectConfig-  ,LocalConfigStatus(..)+  ,loadBuildConfig   ) where  import           Control.Monad.Extra (firstJustM) import           Stack.Prelude-import           Data.Aeson.Extended+import           Pantry.Internal.AesonExtended import qualified Data.ByteString as S+import           Data.ByteString.Builder (byteString) import           Data.Coerce (coerce) import qualified Data.IntMap as IntMap import qualified Data.Map as Map+import qualified Data.Map.Merge.Strict as MS import qualified Data.Monoid import           Data.Monoid.Map (MonoidMap(..)) import qualified Data.Text as T import           Data.Text.Encoding (encodeUtf8) import qualified Data.Yaml as Yaml-import qualified Distribution.PackageDescription as C import           Distribution.System (OS (..), Platform (..), buildPlatform, Arch(OtherArch)) import qualified Distribution.Text import           Distribution.Version (simplifyVersionRange, mkVersion') import           GHC.Conc (getNumProcessors)-import           Lens.Micro (lens, set)+import           Lens.Micro ((.~)) import           Network.HTTP.StackClient (httpJSON, parseUrlThrow, getResponseBody) import           Options.Applicative (Parser, strOption, long, help) import           Path@@ -75,27 +61,26 @@ import           Stack.Config.Build import           Stack.Config.Docker import           Stack.Config.Nix-import           Stack.Config.Urls import           Stack.Constants-import qualified Stack.Image as Image-import           Stack.PackageLocation-import           Stack.PackageIndex (CabalLoader (..), HasCabalLoader (..))-import           Stack.Snapshot-import           Stack.Types.BuildPlan+import           Stack.Build.Haddock (shouldHaddockDeps)+import           Stack.Lock (lockCachedWanted)+import           Stack.Storage (initStorage)+import           Stack.SourceMap+import           Stack.Types.Build import           Stack.Types.Compiler import           Stack.Types.Config import           Stack.Types.Docker import           Stack.Types.Nix-import           Stack.Types.PackageName (PackageName)-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageIndex (IndexType (ITHackageSecurity), HackageSecurity (..)) import           Stack.Types.Resolver-import           Stack.Types.Runner-import           Stack.Types.Urls+import           Stack.Types.SourceMap import           Stack.Types.Version+import           System.Console.ANSI (hSupportsANSIWithoutEmulation) import           System.Environment+import           System.Info.ShortPathName (getShortPathName) import           System.PosixCompat.Files (fileOwner, getFileStatus) import           System.PosixCompat.User (getEffectiveUserID)+import           RIO.List (unzip)+import           RIO.PrettyPrint (stylesUpdateL, useColorL) import           RIO.Process  -- | If deprecated path exists, use it and print a warning.@@ -143,15 +128,6 @@   where     stackRoot = view stackRootL config --- | This is slightly more expensive than @'asks' ('bcStackYaml' '.' 'getBuildConfig')@--- and should only be used when no 'BuildConfig' is at hand.-getStackYaml :: HasConfig env => RIO env (Path Abs File)-getStackYaml = do-    config <- view configL-    case configMaybeProject config of-        Just (_project, stackYaml) -> return stackYaml-        Nothing -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir config)- -- | Download the 'Snapshots' value from stackage.org. getSnapshots :: HasConfig env => RIO env Snapshots getSnapshots = do@@ -165,123 +141,88 @@ -- | Turn an 'AbstractResolver' into a 'Resolver'. makeConcreteResolver     :: HasConfig env-    => Maybe (Path Abs Dir) -- ^ root of project for resolving custom relative paths-    -> AbstractResolver-    -> RIO env Resolver-makeConcreteResolver root (ARResolver r) = parseCustomLocation root r-makeConcreteResolver root ar = do+    => AbstractResolver+    -> RIO env RawSnapshotLocation+makeConcreteResolver (ARResolver r) = pure r+makeConcreteResolver ar = do     snapshots <- getSnapshots     r <-         case ar of-            ARResolver r -> assert False $ makeConcreteResolver root $ ARResolver r+            ARResolver r -> assert False $ makeConcreteResolver (ARResolver r)             ARGlobal -> do                 config <- view configL                 implicitGlobalDir <- getImplicitGlobalProjectDir config                 let fp = implicitGlobalDir </> stackDotYaml-                ProjectAndConfigMonoid project _ <--                    loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp+                iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp+                ProjectAndConfigMonoid project _ <- liftIO iopc                 return $ projectResolver project-            ARLatestNightly -> return $ ResolverStackage $ Nightly $ snapshotsNightly snapshots+            ARLatestNightly -> return $ nightlySnapshotLocation $ snapshotsNightly snapshots             ARLatestLTSMajor x ->                 case IntMap.lookup x $ snapshotsLts snapshots of                     Nothing -> throwString $ "No LTS release found with major version " ++ show x-                    Just y -> return $ ResolverStackage $ LTS x y+                    Just y -> return $ ltsSnapshotLocation x y             ARLatestLTS                 | IntMap.null $ snapshotsLts snapshots -> throwString "No LTS releases found"                 | otherwise ->                     let (x, y) = IntMap.findMax $ snapshotsLts snapshots-                     in return $ ResolverStackage $ LTS x y-    logInfo $ "Selected resolver: " <> display (resolverRawName r)+                     in return $ ltsSnapshotLocation x y+    logInfo $ "Selected resolver: " <> display r     return r  -- | Get the latest snapshot resolver available.-getLatestResolver :: HasConfig env => RIO env (ResolverWith a)+getLatestResolver :: HasConfig env => RIO env RawSnapshotLocation getLatestResolver = do     snapshots <- getSnapshots-    let mlts = do-            (x,y) <- listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots)))-            return (LTS x y)-        snap = fromMaybe (Nightly (snapshotsNightly snapshots)) mlts-    return (ResolverStackage snap)---- | Create a 'Config' value when we're not using any local--- configuration files (e.g., the script command)-configNoLocalConfig-    :: HasRunner env-    => Path Abs Dir -- ^ stack root-    -> Maybe AbstractResolver-    -> ConfigMonoid-    -> RIO env Config-configNoLocalConfig _ Nothing _ = throwIO NoResolverWhenUsingNoLocalConfig-configNoLocalConfig stackRoot (Just resolver) configMonoid = do-    userConfigPath <- liftIO $ getFakeConfigPath stackRoot resolver-    configFromConfigMonoid-      stackRoot-      userConfigPath-      False-      (Just resolver)-      Nothing -- project-      configMonoid+    let mlts = uncurry ltsSnapshotLocation <$>+               listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots)))+    pure $ fromMaybe (nightlySnapshotLocation (snapshotsNightly snapshots)) mlts  -- Interprets ConfigMonoid options. configFromConfigMonoid     :: HasRunner env     => Path Abs Dir -- ^ stack root, e.g. ~/.stack     -> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml-    -> Bool -- ^ allow locals?     -> Maybe AbstractResolver-    -> Maybe (Project, Path Abs File)+    -> ProjectConfig (Project, Path Abs File)     -> ConfigMonoid-    -> RIO env Config+    -> (Config -> RIO env a)+    -> RIO env a configFromConfigMonoid-    clStackRoot configUserConfigPath configAllowLocals mresolver-    mproject ConfigMonoid{..} = do+    configStackRoot configUserConfigPath configResolver+    configProject ConfigMonoid{..} inner = do      -- If --stack-work is passed, prefer it. Otherwise, if STACK_WORK      -- is set, use that. If neither, use the default ".stack-work"      mstackWorkEnv <- liftIO $ lookupEnv stackWorkEnvVar-     configWorkDir0 <- maybe (return $(mkRelDir ".stack-work")) (liftIO . parseRelDir) mstackWorkEnv+     let mproject =+           case configProject of+             PCProject pair -> Just pair+             PCGlobalProject -> Nothing+             PCNoProject _deps -> Nothing+         configAllowLocals =+           case configProject of+             PCProject _ -> True+             PCGlobalProject -> True+             PCNoProject _ -> False+     configWorkDir0 <- maybe (return relDirStackWork) (liftIO . parseRelDir) mstackWorkEnv      let configWorkDir = fromFirst configWorkDir0 configMonoidWorkDir-     -- This code is to handle the deprecation of latest-snapshot-url-     configUrls <- case (getFirst configMonoidLatestSnapshotUrl, getFirst (urlsMonoidLatestSnapshot configMonoidUrls)) of-         (Just url, Nothing) -> do-             logWarn "The latest-snapshot-url field is deprecated in favor of 'urls' configuration"-             return (urlsFromMonoid configMonoidUrls) { urlsLatestSnapshot = url }-         _ -> return (urlsFromMonoid configMonoidUrls)-     let clConnectionCount = fromFirst 8 configMonoidConnectionCount-         configHideTHLoading = fromFirst True configMonoidHideTHLoading-         clIndices = fromFirst-            [PackageIndex-                { indexName = IndexName "Hackage"-                , indexLocation = "https://s3.amazonaws.com/hackage.fpcomplete.com/"-                , indexType = ITHackageSecurity HackageSecurity-                            { hsKeyIds =-                                [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"-                                , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"-                                , "280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833"-                                , "2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201"-                                , "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3"-                                , "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"-                                , "772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d"-                                , "aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9"-                                , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"-                                ]-                            , hsKeyThreshold = 3-                            }-                , indexDownloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"-                , indexRequireHashes = False-                }]-            configMonoidPackageIndices+         configLatestSnapshot = fromFirst+           "https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"+           configMonoidLatestSnapshot+         clConnectionCount = fromFirst 8 configMonoidConnectionCount+         configHideTHLoading = fromFirstTrue configMonoidHideTHLoading -         configGHCVariant0 = getFirst configMonoidGHCVariant+         configGHCVariant = getFirst configMonoidGHCVariant+         configCompilerRepository = fromFirst+            defaultCompilerRepository+            configMonoidCompilerRepository          configGHCBuild = getFirst configMonoidGHCBuild-         configInstallGHC = fromFirst True configMonoidInstallGHC-         configSkipGHCCheck = fromFirst False configMonoidSkipGHCCheck-         configSkipMsys = fromFirst False configMonoidSkipMsys+         configInstallGHC = fromFirstTrue configMonoidInstallGHC+         configSkipGHCCheck = fromFirstFalse configMonoidSkipGHCCheck+         configSkipMsys = fromFirstFalse configMonoidSkipMsys           configExtraIncludeDirs = configMonoidExtraIncludeDirs          configExtraLibDirs = configMonoidExtraLibDirs          configOverrideGccPath = getFirst configMonoidOverrideGccPath-         configOverrideHpack = maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack           -- Only place in the codebase where platform is hard-coded. In theory          -- in the future, allow it to be configured.@@ -293,8 +234,6 @@           configRequireStackVersion = simplifyVersionRange (getIntersectingVersionRange configMonoidRequireStackVersion) -         configImage = Image.imgOptsFromMonoid configMonoidImageOpts-          configCompilerCheck = fromFirst MatchMinor configMonoidCompilerCheck       case arch of@@ -307,7 +246,7 @@       let configBuild = buildOptsFromMonoid configMonoidBuildOpts      configDocker <--         dockerOptsFromMonoid (fmap fst mproject) clStackRoot mresolver configMonoidDockerOpts+         dockerOptsFromMonoid (fmap fst mproject) configResolver configMonoidDockerOpts      configNix <- nixOptsFromMonoid configMonoidNixOpts os       configSystemGHC <-@@ -320,7 +259,7 @@                          (dockerEnable configDocker || nixEnable configNix)                          configMonoidSystemGHC) -     when (isJust configGHCVariant0 && configSystemGHC) $+     when (isJust configGHCVariant && configSystemGHC) $          throwM ManualGHCVariantSettingsAreIncompatibleWithSystemGHC       rawEnv <- liftIO getEnvironment@@ -331,8 +270,22 @@      let configProcessContextSettings _ = return origEnv       configLocalProgramsBase <- case getFirst configMonoidLocalProgramsBase of-       Nothing -> getDefaultLocalProgramsBase clStackRoot configPlatform origEnv+       Nothing -> getDefaultLocalProgramsBase configStackRoot configPlatform origEnv        Just path -> return path+     let localProgramsFilePath = toFilePath configLocalProgramsBase+     when (osIsWindows && ' ' `elem` localProgramsFilePath) $ do+       ensureDir configLocalProgramsBase+       -- getShortPathName returns the long path name when a short name does not+       -- exist.+       shortLocalProgramsFilePath <-+         liftIO $ getShortPathName localProgramsFilePath+       when (' ' `elem` shortLocalProgramsFilePath) $ do+         logWarn $ "Stack's 'programs' path contains a space character and " <>+           "has no alternative short ('8 dot 3') name. This will cause " <>+           "problems with packages that use the GNU project's 'configure' " <>+           "shell script. Use the 'local-programs-path' configuation option " <>+           "to specify an alternative path. The current 'shortest' path is: " <>+           display (T.pack shortLocalProgramsFilePath)      platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform, configPlatformVariant)      let configLocalPrograms = configLocalProgramsBase </> platformOnlyDir @@ -340,7 +293,7 @@          case getFirst configMonoidLocalBinPath of              Nothing -> do                  localDir <- getAppUserDataDir "local"-                 return $ localDir </> $(mkRelDir "bin")+                 return $ localDir </> relDirBin              Just userPath ->                  (case mproject of                      -- Not in a project@@ -361,37 +314,68 @@       let configTemplateParams = configMonoidTemplateParameters          configScmInit = getFirst configMonoidScmInit+         configCabalConfigOpts = coerce configMonoidCabalConfigOpts          configGhcOptionsByName = coerce configMonoidGhcOptionsByName          configGhcOptionsByCat = coerce configMonoidGhcOptionsByCat          configSetupInfoLocations = configMonoidSetupInfoLocations          configPvpBounds = fromFirst (PvpBounds PvpBoundsNone False) configMonoidPvpBounds-         configModifyCodePage = fromFirst True configMonoidModifyCodePage+         configModifyCodePage = fromFirstTrue configMonoidModifyCodePage          configExplicitSetupDeps = configMonoidExplicitSetupDeps-         configRebuildGhcOptions = fromFirst False configMonoidRebuildGhcOptions+         configRebuildGhcOptions = fromFirstFalse configMonoidRebuildGhcOptions          configApplyGhcOptions = fromFirst AGOLocals configMonoidApplyGhcOptions          configAllowNewer = fromFirst False configMonoidAllowNewer          configDefaultTemplate = getFirst configMonoidDefaultTemplate          configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs          configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds          configHackageBaseUrl = fromFirst "https://hackage.haskell.org/" configMonoidHackageBaseUrl-         clIgnoreRevisionMismatch = fromFirst False configMonoidIgnoreRevisionMismatch+         configHideSourcePaths = fromFirstTrue configMonoidHideSourcePaths+         configRecommendUpgrade = fromFirstTrue configMonoidRecommendUpgrade       configAllowDifferentUser <-         case getFirst configMonoidAllowDifferentUser of             Just True -> return True             _ -> getInContainer -     let configMaybeProject = mproject-      configRunner' <- view runnerL -     clCache <- newIORef Nothing-     clUpdateRef <- newMVar True+     useAnsi <- liftIO $ fromMaybe True <$>+                         hSupportsANSIWithoutEmulation stderr -     let configRunner = set processContextL origEnv configRunner'-         configCabalLoader = CabalLoader {..}+     let stylesUpdate' = (configRunner' ^. stylesUpdateL) <>+           configMonoidStyles+         useColor' = runnerUseColor configRunner'+         mUseColor = do+            colorWhen <- getFirst configMonoidColorWhen+            return $ case colorWhen of+                ColorNever  -> False+                ColorAlways -> True+                ColorAuto  -> useAnsi+         configRunner = configRunner'+             & processContextL .~ origEnv+             & stylesUpdateL .~ stylesUpdate'+             & useColorL .~ fromMaybe useColor' mUseColor -     return Config {..}+     hsc <-+       case getFirst configMonoidPackageIndices of+         Nothing -> pure defaultHackageSecurityConfig+         Just [hsc] -> pure hsc+         Just x -> error $ "When overriding the default package index, you must provide exactly one value, received: " ++ show x+     mpantryRoot <- liftIO $ lookupEnv "PANTRY_ROOT"+     pantryRoot <-+       case mpantryRoot of+         Just dir ->+           case parseAbsDir dir of+             Nothing -> throwString $ "Failed to parse PANTRY_ROOT environment variable (expected absolute directory): " ++ show dir+             Just x -> pure x+         Nothing -> pure $ configStackRoot </> relDirPantry+     withPantryConfig+       pantryRoot+       hsc+       (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack)+       clConnectionCount+       (\configPantryConfig -> initStorage+         (configStackRoot </> relFileStorage)+         (\configStorage -> inner Config {..}))  -- | Get the default location of the local programs directory. getDefaultLocalProgramsBase :: MonadThrow m@@ -401,7 +385,7 @@                             -> m (Path Abs Dir) getDefaultLocalProgramsBase configStackRoot configPlatform override =   let-    defaultBase = configStackRoot </> $(mkRelDir "programs")+    defaultBase = configStackRoot </> relDirPrograms   in     case configPlatform of       -- For historical reasons, on Windows a subdirectory of LOCALAPPDATA is@@ -413,162 +397,84 @@           Just t ->             case parseAbsDir $ T.unpack t of               Nothing -> throwM $ stringException ("Failed to parse LOCALAPPDATA environment variable (expected absolute directory): " ++ show t)-              Just lad -> return $ lad </> $(mkRelDir "Programs") </> $(mkRelDir stackProgName)+              Just lad ->+                return $ lad </> relDirUpperPrograms </> relDirStackProgName           Nothing -> return defaultBase       _ -> return defaultBase --- | An environment with a subset of BuildConfig used for setup.-data MiniConfig = MiniConfig -- TODO do we really need a whole extra data type?-    { mcGHCVariant :: !GHCVariant-    , mcConfig :: !Config-    }-instance HasConfig MiniConfig where-    configL = lens mcConfig (\x y -> x { mcConfig = y })-instance HasProcessContext MiniConfig where-    processContextL = configL.processContextL-instance HasCabalLoader MiniConfig where-    cabalLoaderL = configL.cabalLoaderL-instance HasPlatform MiniConfig-instance HasGHCVariant MiniConfig where-    ghcVariantL = lens mcGHCVariant (\x y -> x { mcGHCVariant = y })-instance HasRunner MiniConfig where-    runnerL = configL.runnerL-instance HasLogFunc MiniConfig where-    logFuncL = configL.logFuncL---- | Load the 'MiniConfig'.-loadMiniConfig :: Config -> MiniConfig-loadMiniConfig config = MiniConfig-  { mcGHCVariant = configGHCVariantDefault config-  , mcConfig = config-  }--configGHCVariantDefault :: Config -> GHCVariant -- FIXME why not just use this as the HasGHCVariant instance for Config?-configGHCVariantDefault = fromMaybe GHCStandard . configGHCVariant0---- Load the configuration, using environment variables, and defaults as--- necessary.-loadConfigMaybeProject-    :: HasRunner env-    => ConfigMonoid-    -- ^ Config monoid from parsed command-line arguments-    -> Maybe AbstractResolver-    -- ^ Override resolver-    -> LocalConfigStatus (Project, Path Abs File, ConfigMonoid)-    -- ^ Project config to use, if any-    -> RIO env LoadConfig-loadConfigMaybeProject configArgs mresolver mproject = do+-- | Load the configuration, using current directory, environment variables,+-- and defaults as necessary.+loadConfig :: HasRunner env => (Config -> RIO env a) -> RIO env a+loadConfig inner = do+    mstackYaml <- view $ globalOptsL.to globalStackYaml+    mproject <- loadProjectConfig mstackYaml+    mresolver <- view $ globalOptsL.to globalResolver+    configArgs <- view $ globalOptsL.to globalConfigMonoid     (stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership configArgs -    let loadHelper mproject' = do-          userConfigPath <- getDefaultUserConfigPath stackRoot-          extraConfigs0 <- getExtraConfigs userConfigPath >>=-              mapM (\file -> loadConfigYaml (parseConfigMonoid (parent file)) file)-          let extraConfigs =-                -- non-project config files' existence of a docker section should never default docker-                -- to enabled, so make it look like they didn't exist-                map (\c -> c {configMonoidDockerOpts =-                                  (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = Any False}})-                    extraConfigs0+    let (mproject', addConfigMonoid) =+          case mproject of+            PCProject (proj, fp, cm) -> (PCProject (proj, fp), (cm:))+            PCGlobalProject -> (PCGlobalProject, id)+            PCNoProject deps -> (PCNoProject deps, id) +    userConfigPath <- getDefaultUserConfigPath stackRoot+    extraConfigs0 <- getExtraConfigs userConfigPath >>=+        mapM (\file -> loadConfigYaml (parseConfigMonoid (parent file)) file)+    let extraConfigs =+          -- non-project config files' existence of a docker section should never default docker+          -- to enabled, so make it look like they didn't exist+          map (\c -> c {configMonoidDockerOpts =+                            (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = Any False}})+              extraConfigs0++    let withConfig =           configFromConfigMonoid             stackRoot             userConfigPath-            True -- allow locals             mresolver-            (fmap (\(x, y, _) -> (x, y)) mproject')-            $ mconcat $ configArgs-            : maybe id (\(_, _, projectConfig) -> (projectConfig:)) mproject' extraConfigs--    config <--        case mproject of-          LCSNoConfig _ -> configNoLocalConfig stackRoot mresolver configArgs-          LCSProject project -> loadHelper $ Just project-          LCSNoProject -> loadHelper Nothing-    unless (fromCabalVersion (mkVersion' Meta.version) `withinRange` configRequireStackVersion config)-        (throwM (BadStackVersionException (configRequireStackVersion config)))--    let mprojectRoot = fmap (\(_, fp, _) -> parent fp) mproject-    unless (configAllowDifferentUser config) $ do-        unless userOwnsStackRoot $-            throwM (UserDoesn'tOwnDirectory stackRoot)-        forM_ mprojectRoot $ \dir ->-            checkOwnership (dir </> configWorkDir config)--    return LoadConfig-        { lcConfig          = config-        , lcLoadBuildConfig = runRIO config . loadBuildConfig mproject mresolver-        , lcProjectRoot     =-            case mprojectRoot of-              LCSProject fp -> Just fp-              LCSNoProject  -> Nothing-              LCSNoConfig _ -> Nothing-        }+            mproject'+            (mconcat $ configArgs : addConfigMonoid extraConfigs) --- | 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 :: HasRunner env-           => ConfigMonoid-           -- ^ Config monoid from parsed command-line arguments-           -> Maybe AbstractResolver-           -- ^ Override resolver-           -> StackYamlLoc (Path Abs File)-           -- ^ Override stack.yaml-           -> RIO env LoadConfig-loadConfig configArgs mresolver mstackYaml =-    loadProjectConfig mstackYaml >>= loadConfigMaybeProject configArgs mresolver+    withConfig $ \config -> do+      unless (mkVersion' Meta.version `withinRange` configRequireStackVersion config)+          (throwM (BadStackVersionException (configRequireStackVersion config)))+      unless (configAllowDifferentUser config) $ do+          unless userOwnsStackRoot $+              throwM (UserDoesn'tOwnDirectory stackRoot)+          forM_ (configProjectRoot config) $ \dir ->+              checkOwnership (dir </> configWorkDir config)+      inner config  -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values.-loadBuildConfig :: LocalConfigStatus (Project, Path Abs File, ConfigMonoid)-                -> Maybe AbstractResolver -- override resolver-                -> Maybe (CompilerVersion 'CVWanted) -- override compiler-                -> RIO Config BuildConfig-loadBuildConfig mproject maresolver mcompiler = do+loadBuildConfig :: RIO Config BuildConfig+loadBuildConfig = do     config <- ask      -- If provided, turn the AbstractResolver from the command line     -- into a Resolver that can be used below. -    -- The maresolver and mcompiler are provided on the command+    -- The configResolver and mcompiler are provided on the command     -- line. In order to properly deal with an AbstractResolver, we     -- need a base directory (to deal with custom snapshot relative     -- paths). We consider the current working directory to be the     -- correct base. Let's calculate the mresolver first.-    mresolver <- forM maresolver $ \aresolver -> do-      -- For display purposes only-      let name =-            case aresolver of-              ARResolver resolver -> resolverRawName resolver-              ARLatestNightly -> "nightly"-              ARLatestLTS -> "lts"-              ARLatestLTSMajor x -> T.pack $ "lts-" ++ show x-              ARGlobal -> "global"-      logDebug ("Using resolver: " <> display name <> " specified on command line")--      -- In order to resolve custom snapshots, we need a base-      -- directory to deal with relative paths. For the case of-      -- LCSNoConfig, we use the parent directory provided. This is-      -- because, when running the script interpreter, we assume the-      -- resolver is in fact coming from the file contents itself and-      -- not the command line. For the project and non project cases,-      -- however, we use the current directory.-      base <--        case mproject of-          LCSNoConfig parentDir -> return parentDir-          LCSProject _ -> resolveDir' "."-          LCSNoProject -> resolveDir' "."-      makeConcreteResolver (Just base) aresolver+    mresolver <- forM (configResolver config) $ \aresolver -> do+      logDebug ("Using resolver: " <> display aresolver <> " specified on command line")+      makeConcreteResolver aresolver -    (project', stackYamlFP) <- case mproject of-      LCSProject (project, fp, _) -> do+    (project', stackYamlFP) <- case configProject config of+      PCProject (project, fp) -> do           forM_ (projectUserMsg project) (logWarn . fromString)           return (project, fp)-      LCSNoConfig _ -> do-          p <- assert (isJust mresolver) (getEmptyProject mresolver)+      PCNoProject extraDeps -> do+          p <-+            case mresolver of+              Nothing -> throwIO NoResolverWhenUsingNoProject+              Just _ -> getEmptyProject mresolver extraDeps           return (p, configUserConfigPath config)-      LCSNoProject -> do+      PCGlobalProject -> do             logDebug "Run from outside a project, using implicit global project config"             destDir <- getImplicitGlobalProjectDir config             let dest :: Path Abs File@@ -579,13 +485,14 @@             exists <- doesFileExist dest             if exists                then do-                   ProjectAndConfigMonoid project _ <- loadConfigYaml (parseProjectAndConfigMonoid destDir) dest+                   iopc <- loadConfigYaml (parseProjectAndConfigMonoid destDir) dest+                   ProjectAndConfigMonoid project _ <- liftIO iopc                    when (view terminalL config) $-                       case maresolver of+                       case configResolver config of                            Nothing ->                                logDebug $                                  "Using resolver: " <>-                                 display (resolverRawName (projectResolver project)) <>+                                 display (projectResolver project) <>                                  " from implicit global project's config file: " <>                                  fromString dest'                            Just _ -> return ()@@ -593,9 +500,9 @@                else do                    logInfo ("Writing implicit global project config file to: " <> fromString dest')                    logInfo "Note: You can change the snapshot via the resolver field there."-                   p <- getEmptyProject mresolver+                   p <- getEmptyProject mresolver []                    liftIO $ do-                       S.writeFile dest' $ S.concat+                       writeBinaryFileAtomic dest $ byteString $ S.concat                            [ "# This is the implicit global project's config file, which is only used when\n"                            , "# 'stack' is run outside of a real project.  Settings here do _not_ act as\n"                            , "# defaults for all projects.  To change stack's default settings, edit\n"@@ -605,93 +512,126 @@                            , "# http://docs.haskellstack.org/en/stable/yaml_configuration/\n"                            , "#\n"                            , Yaml.encode p]-                       S.writeFile (toFilePath $ parent dest </> $(mkRelFile "README.txt")) $ S.concat-                           [ "This is the implicit global project, which is used only when 'stack' is run\n"-                           , "outside of a real project.\n" ]+                       writeBinaryFileAtomic (parent dest </> relFileReadmeTxt)+                           "This is the implicit global project, which is used only when 'stack' is run\n\+                           \outside of a real project.\n"                    return (p, dest)+    mcompiler <- view $ globalOptsL.to globalCompiler     let project = project'             { projectCompiler = mcompiler <|> projectCompiler project'             , projectResolver = fromMaybe (projectResolver project') mresolver             }--    sd0 <- runRIO config $ loadResolver $ projectResolver project-    let sd = maybe id setCompilerVersion (projectCompiler project) sd0-     extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) +    wanted <- lockCachedWanted stackYamlFP (projectResolver project) $+        fillProjectWanted stackYamlFP config project+     return BuildConfig         { bcConfig = config-        , bcSnapshotDef = sd-        , bcGHCVariant = configGHCVariantDefault config-        , bcPackages = projectPackages project-        , bcDependencies = projectDependencies project+        , bcSMWanted = wanted         , bcExtraPackageDBs = extraPackageDBs         , bcStackYaml = stackYamlFP-        , bcFlags = projectFlags project-        , bcImplicitGlobal =-            case mproject of-                LCSNoProject -> True-                LCSProject _ -> False-                LCSNoConfig _ -> False+        , bcCurator = projectCurator project         }   where-    getEmptyProject :: Maybe Resolver -> RIO Config Project-    getEmptyProject mresolver = do+    getEmptyProject :: Maybe RawSnapshotLocation -> [PackageIdentifierRevision] -> RIO Config Project+    getEmptyProject mresolver extraDeps = do       r <- case mresolver of             Just resolver -> do-                logInfo ("Using resolver: " <> display (resolverRawName resolver) <> " specified on command line")+                logInfo ("Using resolver: " <> display resolver <> " specified on command line")                 return resolver             Nothing -> do                 r'' <- getLatestResolver-                logInfo ("Using latest snapshot resolver: " <> display (resolverRawName r''))+                logInfo ("Using latest snapshot resolver: " <> display r'')                 return r''       return Project         { projectUserMsg = Nothing         , projectPackages = []-        , projectDependencies = []+        , projectDependencies = map (RPLImmutable . flip RPLIHackage Nothing) extraDeps         , projectFlags = mempty         , projectResolver = r         , projectCompiler = Nothing         , projectExtraPackageDBs = []+        , projectCurator = Nothing+        , projectDropPackages = mempty         } --- | Get packages from EnvConfig, downloading and cloning as necessary.--- If the packages have already been downloaded, this uses a cached value.-getLocalPackages :: forall env. HasEnvConfig env => RIO env LocalPackages-getLocalPackages = do-    cacheRef <- view $ envConfigL.to envConfigPackagesRef-    mcached <- liftIO $ readIORef cacheRef-    case mcached of-        Just cached -> return cached-        Nothing -> do-            root <- view projectRootL-            bc <- view buildConfigL+fillProjectWanted ::+       (HasProcessContext env, HasLogFunc env, HasPantryConfig env)+    => Path Abs t+    -> Config+    -> Project+    -> Map RawPackageLocationImmutable PackageLocationImmutable+    -> WantedCompiler+    -> Map PackageName (Bool -> RIO env DepPackage)+    -> RIO env (SMWanted, [CompletedPLI])+fillProjectWanted stackYamlFP config project locCache snapCompiler snapPackages = do+    let bopts = configBuild config -            packages <- do-              let withName lpv = (lpvName lpv, lpv)-              map withName . concat <$> mapM (parseMultiCabalFiles root True) (bcPackages bc)+    packages0 <- for (projectPackages project) $ \fp@(RelFilePath t) -> do+      abs' <- resolveDir (parent stackYamlFP) (T.unpack t)+      let resolved = ResolvedPath fp abs'+      pp <- mkProjectPackage YesPrintWarnings resolved (boptsHaddock bopts)+      pure (cpName $ ppCommon pp, pp) -            let wrapGPD (gpd, loc) =-                     let PackageIdentifier name _version =-                                fromCabalPackageIdentifier-                              $ C.package-                              $ C.packageDescription gpd-                      in (name, (gpd, loc))-            deps <- map wrapGPD . concat-                <$> mapM (parseMultiCabalFilesIndex root) (bcDependencies bc)+    (deps0, mcompleted) <- fmap unzip . forM (projectDependencies project) $ \rpl -> do+      (pl, mCompleted) <- case rpl of+         RPLImmutable rpli -> do+           compl <- maybe (completePackageLocation rpli) pure (Map.lookup rpli locCache)+           pure (PLImmutable compl, Just (CompletedPLI rpli compl))+         RPLMutable p ->+           pure (PLMutable p, Nothing)+      dp <- additionalDepPackage (shouldHaddockDeps bopts) pl+      pure ((cpName $ dpCommon dp, dp), mCompleted) -            checkDuplicateNames $-              map (second (PLOther . lpvLoc)) packages ++-              map (second snd) deps+    checkDuplicateNames $+      map (second (PLMutable . ppResolvedDir)) packages0 +++      map (second dpLocation) deps0 -            return LocalPackages-              { lpProject = Map.fromList packages-              , lpDependencies = Map.fromList deps-              }+    let packages1 = Map.fromList packages0+        snPackages = snapPackages+          `Map.difference` packages1+          `Map.difference` Map.fromList deps0+          `Map.withoutKeys` projectDropPackages project +    snDeps <- for snPackages $ \getDep -> getDep (shouldHaddockDeps bopts)++    let deps1 = Map.fromList deps0 `Map.union` snDeps++    let mergeApply m1 m2 f =+          MS.merge MS.preserveMissing MS.dropMissing (MS.zipWithMatched f) m1 m2+        pFlags = projectFlags project+        packages2 = mergeApply packages1 pFlags $+          \_ p flags -> p{ppCommon=(ppCommon p){cpFlags=flags}}+        deps2 = mergeApply deps1 pFlags $+          \_ d flags -> d{dpCommon=(dpCommon d){cpFlags=flags}}++    checkFlagsUsedThrowing pFlags FSStackYaml packages1 deps1++    let pkgGhcOptions = configGhcOptionsByName config+        deps = mergeApply deps2 pkgGhcOptions $+          \_ d options -> d{dpCommon=(dpCommon d){cpGhcOptions=options}}+        packages = mergeApply packages2 pkgGhcOptions $+          \_ p options -> p{ppCommon=(ppCommon p){cpGhcOptions=options}}+        unusedPkgGhcOptions = pkgGhcOptions `Map.restrictKeys` Map.keysSet packages2+          `Map.restrictKeys` Map.keysSet deps2++    unless (Map.null unusedPkgGhcOptions) $+      throwM $ InvalidGhcOptionsSpecification (Map.keys unusedPkgGhcOptions)++    let wanted = SMWanted+          { smwCompiler = fromMaybe snapCompiler (projectCompiler project)+          , smwProject = packages+          , smwDeps = deps+          , smwSnapshotLocation = projectResolver project+          }++    pure (wanted, catMaybes mcompleted)++ -- | Check if there are any duplicate package names and, if so, throw an -- exception.-checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocationIndex FilePath)] -> m ()+checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocation)] -> m () checkDuplicateNames locals =     case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map (second return) locals of         [] -> return ()@@ -832,19 +772,20 @@  -- | Get the location of the project config file, if it exists. getProjectConfig :: HasLogFunc env-                 => StackYamlLoc (Path Abs File)+                 => StackYamlLoc                  -- ^ Override stack.yaml-                 -> RIO env (LocalConfigStatus (Path Abs File))-getProjectConfig (SYLOverride stackYaml) = return $ LCSProject stackYaml+                 -> RIO env (ProjectConfig (Path Abs File))+getProjectConfig (SYLOverride stackYaml) = return $ PCProject stackYaml+getProjectConfig SYLGlobalProject = return PCGlobalProject getProjectConfig SYLDefault = do     env <- liftIO getEnvironment     case lookup "STACK_YAML" env of         Just fp -> do             logInfo "Getting project config file from STACK_YAML environment"-            liftM LCSProject $ resolveFile' fp+            liftM PCProject $ resolveFile' fp         Nothing -> do             currDir <- getCurrentDir-            maybe LCSNoProject LCSProject <$> findInParents getStackDotYaml currDir+            maybe PCGlobalProject PCProject <$> findInParents getStackDotYaml currDir   where     getStackDotYaml dir = do         let fp = dir </> stackDotYaml@@ -854,39 +795,33 @@         if exists             then return $ Just fp             else return Nothing-getProjectConfig (SYLNoConfig parentDir) = return (LCSNoConfig parentDir)--data LocalConfigStatus a-    = LCSNoProject-    | LCSProject a-    | LCSNoConfig !(Path Abs Dir)-    -- ^ parent directory for making a concrete resolving-    deriving (Show,Functor,Foldable,Traversable)+getProjectConfig (SYLNoProject extraDeps) = return $ PCNoProject extraDeps  -- | Find the project config file location, respecting environment variables -- and otherwise traversing parents. If no config is found, we supply a default -- based on current directory. loadProjectConfig :: HasLogFunc env-                  => StackYamlLoc (Path Abs File)+                  => StackYamlLoc                   -- ^ Override stack.yaml-                  -> RIO env (LocalConfigStatus (Project, Path Abs File, ConfigMonoid))+                  -> RIO env (ProjectConfig (Project, Path Abs File, ConfigMonoid)) loadProjectConfig mstackYaml = do     mfp <- getProjectConfig mstackYaml     case mfp of-        LCSProject fp -> do+        PCProject fp -> do             currDir <- getCurrentDir             logDebug $ "Loading project config file " <>                         fromString (maybe (toFilePath fp) toFilePath (stripProperPrefix currDir fp))-            LCSProject <$> load fp-        LCSNoProject -> do+            PCProject <$> load fp+        PCGlobalProject -> do             logDebug "No project config file found, using defaults."-            return LCSNoProject-        LCSNoConfig mparentDir -> do+            return PCGlobalProject+        PCNoProject extraDeps -> do             logDebug "Ignoring config files"-            return (LCSNoConfig mparentDir)+            return $ PCNoProject extraDeps   where     load fp = do-        ProjectAndConfigMonoid project config <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp+        iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp+        ProjectAndConfigMonoid project config <- liftIO iopc         return (project, fp, config)  -- | Get the location of the default stack configuration file.@@ -921,50 +856,32 @@         (defaultUserConfigPathDeprecated stackRoot)     unless exists $ do         ensureDir (parent path)-        liftIO $ S.writeFile (toFilePath path) defaultConfigYaml+        liftIO $ writeBinaryFileAtomic path defaultConfigYaml     return path --- | Get a fake configuration file location, used when doing a "no--- config" run (the script command).-getFakeConfigPath-    :: (MonadIO m, MonadThrow m)-    => Path Abs Dir -- ^ stack root-    -> AbstractResolver-    -> m (Path Abs File)-getFakeConfigPath stackRoot ar = do-  asString <--    case ar of-      ARResolver r -> return $ T.unpack $ resolverRawName r-      _ -> throwM $ InvalidResolverForNoLocalConfig $ show ar-  -- This takeWhile is an ugly hack. We don't actually need this-  -- path for anything useful. But if we take the raw value for-  -- a custom snapshot, it will be unparseable in a PATH.-  -- Therefore, we add in this silly "strip up to :".-  -- Better would be to defer figuring out this value until-  -- after we have a fully loaded snapshot with a hash.-  asDir <- parseRelDir $ takeWhile (/= ':') asString-  let full = stackRoot </> $(mkRelDir "script") </> asDir </> $(mkRelFile "config.yaml")-  ensureDir (parent full)-  return full- 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:"-     , ""-     ]+defaultConfigYaml :: IsString s => s+defaultConfigYaml =+  "# 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\+  \# The following parameters are used by \"stack new\" to automatically fill fields\n\+  \# in the cabal config. We recommend uncommenting them and filling them out if\n\+  \# you intend to use 'stack new'.\n\+  \# See https://docs.haskellstack.org/en/stable/yaml_configuration/#templates\n\+  \templates:\n\+  \  params:\n\+  \#    author-name:\n\+  \#    author-email:\n\+  \#    copyright:\n\+  \#    github-username:\n\+  \\n\+  \# The following parameter specifies stack's output styles; STYLES is a\n\+  \# colon-delimited sequence of key=value, where 'key' is a style name and\n\+  \# 'value' is a semicolon-delimited list of 'ANSI' SGR (Select Graphic\n\+  \# Rendition) control codes (in decimal). Use \"stack ls stack-colors --basic\"\n\+  \# to see the current sequence.\n\+  \# stack-colors: STYLES\n"
src/Stack/Config/Build.hs view
@@ -10,71 +10,42 @@ -- | Interprets BuildOptsMonoid options. buildOptsFromMonoid :: BuildOptsMonoid -> BuildOpts buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts-    { boptsLibProfile = fromFirst-          (boptsLibProfile defaultBuildOpts)+    { boptsLibProfile = fromFirstFalse           (buildMonoidLibProfile <>-           First (if tracing || profiling then Just True else Nothing))-    , boptsExeProfile = fromFirst-          (boptsExeProfile defaultBuildOpts)+           FirstFalse (if tracing || profiling then Just True else Nothing))+    , boptsExeProfile = fromFirstFalse           (buildMonoidExeProfile <>-           First (if tracing || profiling then Just True else Nothing))-    , boptsLibStrip = fromFirst-          (boptsLibStrip defaultBuildOpts)+           FirstFalse (if tracing || profiling then Just True else Nothing))+    , boptsLibStrip = fromFirstTrue           (buildMonoidLibStrip <>-           First (if noStripping then Just False else Nothing))-    , boptsExeStrip = fromFirst-          (boptsExeStrip defaultBuildOpts)+           FirstTrue (if noStripping then Just False else Nothing))+    , boptsExeStrip = fromFirstTrue           (buildMonoidExeStrip <>-           First (if noStripping then Just False else Nothing))-    , boptsHaddock = fromFirst-          (boptsHaddock defaultBuildOpts)-          buildMonoidHaddock+           FirstTrue (if noStripping then Just False else Nothing))+    , boptsHaddock = fromFirstFalse buildMonoidHaddock     , boptsHaddockOpts = haddockOptsFromMonoid buildMonoidHaddockOpts-    , boptsOpenHaddocks = fromFirst-          (boptsOpenHaddocks defaultBuildOpts)-          buildMonoidOpenHaddocks+    , boptsOpenHaddocks = fromFirstFalse buildMonoidOpenHaddocks     , boptsHaddockDeps = getFirst buildMonoidHaddockDeps-    , boptsHaddockInternal = fromFirst-          (boptsHaddockInternal defaultBuildOpts)-          buildMonoidHaddockInternal-    , boptsHaddockHyperlinkSource = fromFirst-          (boptsHaddockHyperlinkSource defaultBuildOpts)-          buildMonoidHaddockHyperlinkSource-    , boptsInstallExes = fromFirst-          (boptsInstallExes defaultBuildOpts)-          buildMonoidInstallExes-    , boptsInstallCompilerTool = fromFirst-          (boptsInstallCompilerTool defaultBuildOpts)-          buildMonoidInstallCompilerTool-    , boptsPreFetch = fromFirst-          (boptsPreFetch defaultBuildOpts)-          buildMonoidPreFetch+    , boptsHaddockInternal = fromFirstFalse buildMonoidHaddockInternal+    , boptsHaddockHyperlinkSource = fromFirstTrue buildMonoidHaddockHyperlinkSource+    , boptsInstallExes = fromFirstFalse buildMonoidInstallExes+    , boptsInstallCompilerTool = fromFirstFalse buildMonoidInstallCompilerTool+    , boptsPreFetch = fromFirstFalse buildMonoidPreFetch     , boptsKeepGoing = getFirst buildMonoidKeepGoing-    , boptsKeepTmpFiles = getFirst buildMonoidKeepTmpFiles-    , boptsForceDirty = fromFirst-          (boptsForceDirty defaultBuildOpts)-          buildMonoidForceDirty-    , boptsTests = fromFirst (boptsTests defaultBuildOpts) buildMonoidTests+    , boptsKeepTmpFiles = fromFirstFalse buildMonoidKeepTmpFiles+    , boptsForceDirty = fromFirstFalse buildMonoidForceDirty+    , boptsTests = fromFirstFalse buildMonoidTests     , boptsTestOpts =           testOptsFromMonoid buildMonoidTestOpts additionalArgs-    , boptsBenchmarks = fromFirst-          (boptsBenchmarks defaultBuildOpts)-          buildMonoidBenchmarks+    , boptsBenchmarks = fromFirstFalse buildMonoidBenchmarks     , boptsBenchmarkOpts =           benchmarkOptsFromMonoid buildMonoidBenchmarkOpts additionalArgs-    , boptsReconfigure = fromFirst-          (boptsReconfigure defaultBuildOpts)-          buildMonoidReconfigure-    , boptsCabalVerbose = fromFirst-          (boptsCabalVerbose defaultBuildOpts)-          buildMonoidCabalVerbose-    , boptsSplitObjs = fromFirst-          (boptsSplitObjs defaultBuildOpts)-          buildMonoidSplitObjs+    , boptsReconfigure = fromFirstFalse buildMonoidReconfigure+    , boptsCabalVerbose = fromFirstFalse buildMonoidCabalVerbose+    , boptsSplitObjs = fromFirstFalse buildMonoidSplitObjs     , boptsSkipComponents = buildMonoidSkipComponents-    , boptsInterleavedOutput = fromFirst-          (boptsInterleavedOutput defaultBuildOpts)-          buildMonoidInterleavedOutput+    , boptsInterleavedOutput = fromFirstTrue buildMonoidInterleavedOutput+    , boptsDdumpDir = getFirst buildMonoidDdumpDir     }   where     -- These options are not directly used in bopts, instead they@@ -104,10 +75,11 @@ testOptsFromMonoid :: TestOptsMonoid -> Maybe [String] -> TestOpts testOptsFromMonoid TestOptsMonoid{..} madditional =     defaultTestOpts-    { toRerunTests = fromFirst (toRerunTests defaultTestOpts) toMonoidRerunTests+    { toRerunTests = fromFirstTrue toMonoidRerunTests     , toAdditionalArgs = fromMaybe [] madditional <> toMonoidAdditionalArgs-    , toCoverage = fromFirst (toCoverage defaultTestOpts) toMonoidCoverage-    , toDisableRun = fromFirst (toDisableRun defaultTestOpts) toMonoidDisableRun+    , toCoverage = fromFirstFalse toMonoidCoverage+    , toDisableRun = fromFirstFalse toMonoidDisableRun+    , toMaximumTimeSeconds = fromFirst (toMaximumTimeSeconds defaultTestOpts) toMonoidMaximumTimeSeconds     }  benchmarkOptsFromMonoid :: BenchmarkOptsMonoid -> Maybe [String] -> BenchmarkOpts
src/Stack/Config/Docker.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP, DeriveDataTypeable, RecordWildCards, TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}  -- | Docker configuration module Stack.Config.Docker where@@ -7,72 +8,75 @@ import           Stack.Prelude import           Data.List (find) import qualified Data.Text as T+import           Data.Text.Read (decimal) import           Distribution.Version (simplifyVersionRange)-import           Path import           Stack.Types.Version import           Stack.Types.Config import           Stack.Types.Docker import           Stack.Types.Resolver +-- | Add a default Docker tag name to a given base image.+addDefaultTag+  :: MonadThrow m+  => String -- ^ base+  -> Maybe Project+  -> Maybe AbstractResolver+  -> m String+addDefaultTag base mproject maresolver = do+  let exc = throwM $ ResolverNotSupportedException mproject maresolver+      onUrl url = maybe exc pure $ do+        (x, y) <- parseLtsName url+        Just $ concat+          [ base+          , ":lts-"+          , show x+          , "."+          , show y+          ]+  case maresolver of+    Just (ARResolver (RSLUrl url _)) -> onUrl url+    Just _aresolver -> exc+    Nothing ->+      case projectResolver <$> mproject of+        Just (RSLUrl url _) -> onUrl url+        _ -> exc+ -- | Interprets DockerOptsMonoid options. dockerOptsFromMonoid     :: MonadThrow m     => Maybe Project-    -> Path Abs Dir     -> Maybe AbstractResolver     -> DockerOptsMonoid     -> m DockerOpts-dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do+dockerOptsFromMonoid mproject maresolver DockerOptsMonoid{..} = do+    let dockerImage =+          case getFirst dockerMonoidRepoOrImage of+            Nothing -> addDefaultTag "fpco/stack-build" mproject maresolver+            Just (DockerMonoidImage image) -> pure image+            Just (DockerMonoidRepo repo) ->+              case find (`elem` (":@" :: String)) repo of+                Nothing -> addDefaultTag repo mproject maresolver+                -- Repo already specified a tag or digest, so don't append default+                Just _ -> pure repo     let dockerEnable =             fromFirst (getAny dockerMonoidDefaultEnable) dockerMonoidEnable-        dockerImage =-            let mresolver =-                    case maresolver of-                        Just (ARResolver resolver) ->-                            Just (void resolver)-                        Just aresolver ->-                            impureThrow-                                (ResolverNotSupportedException $-                                 show aresolver)-                        Nothing ->-                            fmap (void . projectResolver) mproject-                defaultTag =-                    case mresolver of-                        Nothing -> ""-                        Just resolver ->-                            case resolver of-                                ResolverStackage n@(LTS _ _) ->-                                    ":" ++ T.unpack (renderSnapName n)-                                _ ->-                                    impureThrow-                                        (ResolverNotSupportedException $-                                         show resolver)-            in case getFirst dockerMonoidRepoOrImage of-                   Nothing -> "fpco/stack-build" ++ defaultTag-                   Just (DockerMonoidImage image) -> image-                   Just (DockerMonoidRepo repo) ->-                       case find (`elem` (":@" :: String)) repo of-                           Just _    -- Repo already specified a tag or digest, so don't append default-                            ->-                               repo-                           Nothing -> repo ++ defaultTag         dockerRegistryLogin =             fromFirst                 (isJust (emptyToNothing (getFirst dockerMonoidRegistryUsername)))                 dockerMonoidRegistryLogin         dockerRegistryUsername = emptyToNothing (getFirst dockerMonoidRegistryUsername)         dockerRegistryPassword = emptyToNothing (getFirst dockerMonoidRegistryPassword)-        dockerAutoPull = fromFirst False dockerMonoidAutoPull-        dockerDetach = fromFirst False dockerMonoidDetach-        dockerPersist = fromFirst False dockerMonoidPersist+        dockerAutoPull = fromFirstTrue dockerMonoidAutoPull+        dockerDetach = fromFirstFalse dockerMonoidDetach+        dockerPersist = fromFirstFalse dockerMonoidPersist         dockerContainerName = emptyToNothing (getFirst dockerMonoidContainerName)         dockerRunArgs = dockerMonoidRunArgs         dockerMount = dockerMonoidMount+        dockerMountMode = emptyToNothing (getFirst dockerMonoidMountMode)         dockerEnv = dockerMonoidEnv         dockerSetUser = getFirst dockerMonoidSetUser         dockerRequireDockerVersion =             simplifyVersionRange (getIntersectingVersionRange dockerMonoidRequireDockerVersion)-        dockerDatabasePath = fromFirst (stackRoot </> $(mkRelFile "docker.db")) dockerMonoidDatabasePath         dockerStackExe = getFirst dockerMonoidStackExe      return DockerOpts{..}@@ -82,10 +86,8 @@  -- | Exceptions thrown by Stack.Docker.Config. data StackDockerConfigException-    = ResolverNotSupportedException String+    = ResolverNotSupportedException !(Maybe Project) !(Maybe AbstractResolver)     -- ^ Only LTS resolvers are supported for default image tag.-    | InvalidDatabasePathException SomeException-    -- ^ Invalid global database path.     deriving (Typeable)  -- | Exception instance for StackDockerConfigException.@@ -93,11 +95,24 @@  -- | Show instance for StackDockerConfigException. instance Show StackDockerConfigException where-    show (ResolverNotSupportedException resolver) =+    show (ResolverNotSupportedException mproject maresolver) =         concat             [ "Resolver not supported for Docker images:\n    "-            , resolver+            , case (mproject, maresolver) of+                (Nothing, Nothing) -> "no resolver specified"+                (_, Just aresolver) -> T.unpack $ utf8BuilderToText $ display aresolver+                (Just project, Nothing) -> T.unpack $ utf8BuilderToText $ display $ projectResolver project             , "\nUse an LTS resolver, or set the '"             , T.unpack dockerImageArgName             , "' explicitly, in your configuration file."]-    show (InvalidDatabasePathException ex) = "Invalid database path: " ++ show ex++-- | Parse an LTS major and minor number from a snapshot URL.+--+-- This might make more sense in pantry instead.+parseLtsName :: Text -> Maybe (Int, Int)+parseLtsName t0 = do+  t1 <- T.stripPrefix "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/" t0+  Right (x, t2) <- Just $ decimal t1+  t3 <- T.stripPrefix "/" t2+  Right (y, ".yaml") <- Just $ decimal t3+  Just (x, y)
src/Stack/Config/Nix.hs view
@@ -14,10 +14,8 @@ import qualified Data.Text.IO as TIO import Distribution.System (OS (..)) import Stack.Constants-import Stack.Types.Version+import Stack.Types.Config import Stack.Types.Nix-import Stack.Types.Compiler-import Stack.Types.Runner import System.Directory (doesFileExist)  -- | Interprets NixOptsMonoid options.@@ -35,7 +33,7 @@         nixInitFile = getFirst nixMonoidInitFile         nixShellOptions = fromFirst [] nixMonoidShellOptions                           ++ prefixAll (T.pack "-I") (fromFirst [] nixMonoidPath)-        nixAddGCRoots   = fromFirst False nixMonoidAddGCRoots+        nixAddGCRoots   = fromFirstFalse nixMonoidAddGCRoots      -- Enable Nix-mode by default on NixOS, unless Docker-mode was specified     osIsNixOS <- isNixOS@@ -53,11 +51,11 @@   where prefixAll p (x:xs) = p : x : prefixAll p xs         prefixAll _ _      = [] -nixCompiler :: CompilerVersion a -> Either StringException T.Text+nixCompiler :: WantedCompiler -> Either StringException T.Text nixCompiler compilerVersion =   case compilerVersion of-    GhcVersion version ->-      case T.split (== '.') (versionText version) of+    WCGhc version ->+      case T.split (== '.') (fromString $ versionString version) of         x : y : minor ->           Right $           case minor of@@ -72,11 +70,12 @@               \(lib.attrNames haskell.compiler); in \               \if compilers == [] \               \then abort \"No compiler found for GHC "-              <> versionText version <> "\"\+              <> T.pack (versionString version) <> "\"\               \else haskell.compiler.${builtins.head compilers})"             _ -> "haskell.compiler.ghc" <> T.concat (x : y : minor)         _ -> Left $ stringException "GHC major version not specified"-    _ -> Left $ stringException "Only GHC is supported by stack --nix"+    WCGhcjs{} -> Left $ stringException "Only GHC is supported by stack --nix"+    WCGhcGit{} -> Left $ stringException "Only GHC is supported by stack --nix"  -- Exceptions thown specifically by Stack.Nix data StackNixException
− src/Stack/Config/Urls.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--module Stack.Config.Urls (urlsFromMonoid) where--import           Stack.Types.Urls-import           Stack.Prelude--urlsFromMonoid :: UrlsMonoid -> Urls-urlsFromMonoid monoid =-    Urls-        (fromFirst defaultLatestSnapshot    $ urlsMonoidLatestSnapshot    monoid)-        (fromFirst defaultLtsBuildPlans     $ urlsMonoidLtsBuildPlans     monoid)-        (fromFirst defaultNightlyBuildPlans $ urlsMonoidNightlyBuildPlans monoid)-    where-    defaultLatestSnapshot =-        "https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"-    defaultLtsBuildPlans =-        "https://raw.githubusercontent.com/fpco/lts-haskell/master/"-    defaultNightlyBuildPlans =-        "https://raw.githubusercontent.com/fpco/stackage-nightly/master/"
src/Stack/ConfigCmd.hs view
@@ -11,25 +11,32 @@        ,configCmdSetParser        ,cfgCmdSet        ,cfgCmdSetName+       ,configCmdEnvParser+       ,cfgCmdEnv+       ,cfgCmdEnvName        ,cfgCmdName) where  import           Stack.Prelude-import qualified Data.ByteString as S+import           Data.ByteString.Builder (byteString)+import qualified Data.Map.Merge.Strict as Map import qualified Data.HashMap.Strict as HMap 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           Options.Applicative.Builder.Extra+import           Pantry (completeSnapshotLocation, loadSnapshot) import           Path-import           Path.IO-import           Stack.Config (makeConcreteResolver, getProjectConfig, getImplicitGlobalProjectDir, LocalConfigStatus(..))+import qualified RIO.Map as Map+import           RIO.Process (envVarsL)+import           Stack.Config (makeConcreteResolver, getProjectConfig, getImplicitGlobalProjectDir) import           Stack.Constants-import           Stack.Snapshot (loadResolver) import           Stack.Types.Config import           Stack.Types.Resolver+import           System.Environment (getEnvironment)  data ConfigCmdSet-    = ConfigCmdSetResolver AbstractResolver+    = ConfigCmdSetResolver (Unresolved AbstractResolver)     | ConfigCmdSetSystemGhc CommandScope                             Bool     | ConfigCmdSetInstallGhc CommandScope@@ -49,18 +56,18 @@  cfgCmdSet     :: (HasConfig env, HasGHCVariant env)-    => GlobalOpts -> ConfigCmdSet -> RIO env ()-cfgCmdSet go cmd = do+    => ConfigCmdSet -> RIO env ()+cfgCmdSet cmd = do     conf <- view configL     configFilePath <-              case configCmdSetScope cmd of                  CommandScopeProject -> do-                     mstackYamlOption <- forM (globalStackYaml go) resolveFile'+                     mstackYamlOption <- view $ globalOptsL.to globalStackYaml                      mstackYaml <- getProjectConfig mstackYamlOption                      case mstackYaml of-                         LCSProject stackYaml -> return stackYaml-                         LCSNoProject -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir conf)-                         LCSNoConfig _ -> throwString "config command used when no local configuration available"+                         PCProject stackYaml -> return stackYaml+                         PCGlobalProject -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir conf)+                         PCNoProject _extraDeps -> throwString "config command used when no project configuration available" -- maybe modify the ~/.stack/config.yaml file instead?                  CommandScopeGlobal -> return (configUserConfigPath conf)     -- We don't need to worry about checking for a valid yaml here     (config :: Yaml.Object) <-@@ -73,7 +80,7 @@                  (fromString (toFilePath configFilePath) <>                   " already contained the intended configuration and remains unchanged.")         else do-            liftIO (S.writeFile (toFilePath configFilePath) (Yaml.encode config'))+            writeBinaryFileAtomic configFilePath (byteString (Yaml.encode config'))             logInfo (fromString (toFilePath configFilePath) <> " has been updated.")  cfgCmdSetValue@@ -81,9 +88,10 @@     => Path Abs Dir -- ^ root directory of project     -> ConfigCmdSet -> RIO env Yaml.Value cfgCmdSetValue root (ConfigCmdSetResolver newResolver) = do-    concreteResolver <- makeConcreteResolver (Just root) newResolver+    newResolver' <- resolvePaths (Just root) newResolver+    concreteResolver <- makeConcreteResolver newResolver'     -- Check that the snapshot actually exists-    void $ loadResolver concreteResolver+    void $ loadSnapshot =<< completeSnapshotLocation concreteResolver     return (Yaml.toJSON concreteResolver) cfgCmdSetValue _ (ConfigCmdSetSystemGhc _ bool') =     return (Yaml.Bool bool')@@ -101,6 +109,9 @@ cfgCmdSetName :: String cfgCmdSetName = "set" +cfgCmdEnvName :: String+cfgCmdEnvName = "env"+ configCmdSetParser :: OA.Parser ConfigCmdSet configCmdSetParser =     OA.hsubparser $@@ -148,3 +159,39 @@  boolArgument :: OA.Parser Bool boolArgument = OA.argument readBool (OA.metavar "true|false" <> OA.completeWith ["true", "false"])++configCmdEnvParser :: OA.Parser EnvSettings+configCmdEnvParser = EnvSettings+  <$> boolFlags True "locals" "include local package information" mempty+  <*> boolFlags True "ghc-package-path" "set GHC_PACKAGE_PATH variable" mempty+  <*> boolFlags True "stack-exe" "set STACK_EXE environment variable" mempty+  <*> boolFlags False "locale-utf8" "set the GHC_CHARENC environment variable to UTF8" mempty+  <*> boolFlags False "keep-ghc-rts" "keep any GHC_RTS environment variables" mempty++data EnvVarAction = EVASet !Text | EVAUnset+  deriving Show++cfgCmdEnv :: EnvSettings -> RIO EnvConfig ()+cfgCmdEnv es = do+  origEnv <- liftIO $ Map.fromList . map (first fromString) <$> getEnvironment+  mkPC <- view $ configL.to configProcessContextSettings+  pc <- liftIO $ mkPC es+  let newEnv = pc ^. envVarsL+      actions = Map.merge+        (pure EVAUnset)+        (Map.traverseMissing $ \_k new -> pure (EVASet new))+        (Map.zipWithMaybeAMatched $ \_k old new -> pure $+            if fromString old == new+              then Nothing+              else Just (EVASet new))+        origEnv+        newEnv+      toLine key EVAUnset = "unset " <> encodeUtf8Builder key <> ";\n"+      toLine key (EVASet value) =+        encodeUtf8Builder key <> "='" <>+        encodeUtf8Builder (T.concatMap escape value) <> -- TODO more efficient to use encodeUtf8BuilderEscaped+        "'; export " <>+        encodeUtf8Builder key <> ";\n"+      escape '\'' = "'\"'\"'"+      escape c = T.singleton c+  hPutBuilder stdout $ Map.foldMapWithKey toLine actions
src/Stack/Constants.hs view
@@ -1,14 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-} -- keep TH usage here  -- | Constants used throughout the project.  module Stack.Constants     (buildPlanDir     ,buildPlanCacheDir-    ,haskellModuleExts+    ,haskellFileExts+    ,haskellPreprocessorExts     ,stackDotYaml     ,stackWorkEnvVar     ,stackRootEnvVar@@ -16,7 +17,6 @@     ,deprecatedStackRootOptionName     ,inContainerEnvVar     ,inNixShellEnvVar-    ,stackProgName     ,stackProgNameUpper     ,wiredInPackages     ,ghcjsBootPackages@@ -34,19 +34,108 @@     ,maxTerminalWidth     ,defaultTerminalWidth     ,osIsWindows+    ,relFileSetupHs+    ,relFileSetupLhs+    ,relFileHpackPackageConfig+    ,relDirGlobalAutogen+    ,relDirAutogen+    ,relDirLogs+    ,relFileCabalMacrosH+    ,relDirBuild+    ,relDirBin+    ,relDirPantry+    ,relDirPrograms+    ,relDirUpperPrograms+    ,relDirStackProgName+    ,relDirStackWork+    ,relFileReadmeTxt+    ,relDirScript+    ,relFileConfigYaml+    ,relDirSnapshots+    ,relDirGlobalHints+    ,relFileGlobalHintsYaml+    ,relDirInstall+    ,relDirCompilerTools+    ,relDirHoogle+    ,relFileDatabaseHoo+    ,relDirPkgdb+    ,relFileStorage+    ,relDirLoadedSnapshotCache+    ,bindirSuffix+    ,docDirSuffix+    ,relDirHpc+    ,relDirLib+    ,relDirShare+    ,relDirLibexec+    ,relDirEtc+    ,setupGhciShimCode+    ,relDirSetupExeCache+    ,relDirSetupExeSrc+    ,relFileConfigure+    ,relDirDist+    ,relFileSetupMacrosH+    ,relDirSetup+    ,relFileSetupLower+    ,relDirMingw+    ,relDirMingw32+    ,relDirMingw64+    ,relDirLocal+    ,relDirUsr+    ,relDirInclude+    ,relFileIndexHtml+    ,relDirAll+    ,relFilePackageCache+    ,relFileDockerfile+    ,relDirHaskellStackGhci+    ,relFileGhciScript+    ,relDirCombined+    ,relFileHpcIndexHtml+    ,relDirCustom+    ,relDirPackageConfInplace+    ,relDirExtraTixFiles+    ,relDirInstalledPackages+    ,backupUrlRelPath+    ,relDirDotLocal+    ,relDirDotSsh+    ,relDirDotStackProgName+    ,relDirUnderHome+    ,relDirSrc+    ,relFileLibtinfoSo5+    ,relFileLibtinfoSo6+    ,relFileLibncurseswSo6+    ,relFileLibgmpSo10+    ,relFileLibgmpSo3+    ,relDirNewCabal+    ,relFileSetupExe+    ,relFileSetupUpper+    ,relFile7zexe+    ,relFile7zdll+    ,relFileMainHs+    ,relFileStack+    ,relFileStackDotExe+    ,relFileStackDotTmpDotExe+    ,relFileStackDotTmp+    ,ghcShowOptionsOutput+    ,hadrianCmdWindows+    ,hadrianCmdPosix+    ,usrLibDirs+    ,testGhcEnvRelFile+    ,relFileBuildLock     )     where +import           Data.ByteString.Builder (byteString) import           Data.Char (toUpper)-import qualified Data.HashSet as HashSet+import           Data.FileEmbed (embedFile, makeRelativeToProject)+import qualified Data.Set as Set+import           Distribution.Package (mkPackageName)+import qualified Hpack.Config as Hpack+import qualified Language.Haskell.TH.Syntax as TH (runIO, lift) import           Path as FL import           Stack.Prelude import           Stack.Types.Compiler-import           Stack.Types.PackageName---- | Extensions for anything that can be a Haskell module.-haskellModuleExts :: [Text]-haskellModuleExts = haskellFileExts ++ haskellPreprocessorExts+import           System.Permissions (osIsWindows)+import           System.Process (readProcess)  -- | Extensions used for Haskell modules. Excludes preprocessor ones. haskellFileExts :: [Text]@@ -60,10 +149,6 @@ stackProgNameUpper :: String stackProgNameUpper = map toUpper stackProgName --- | Name of the 'stack' program.-stackProgName :: String-stackProgName = "stack"- -- | The filename used for the stack config file. stackDotYaml :: Path Rel File stackDotYaml = $(mkRelFile "stack.yaml")@@ -100,9 +185,9 @@ inNixShellEnvVar = map toUpper stackProgName ++ "_IN_NIX_SHELL"  -- See https://downloads.haskell.org/~ghc/7.10.1/docs/html/libraries/ghc/src/Module.html#integerPackageKey-wiredInPackages :: HashSet PackageName+wiredInPackages :: Set PackageName wiredInPackages =-    maybe (error "Parse error in wiredInPackages") HashSet.fromList mparsed+    maybe (error "Parse error in wiredInPackages") Set.fromList mparsed   where     mparsed = mapM parsePackageName       [ "ghc-prim"@@ -119,9 +204,9 @@  -- TODO: Get this unwieldy list out of here and into a datafile -- generated by GHCJS! See https://github.com/ghcjs/ghcjs/issues/434-ghcjsBootPackages :: HashSet PackageName+ghcjsBootPackages :: Set PackageName ghcjsBootPackages =-    maybe (error "Parse error in ghcjsBootPackages") HashSet.fromList mparsed+    maybe (error "Parse error in ghcjsBootPackages") Set.fromList mparsed   where     mparsed = mapM parsePackageName       -- stage1a@@ -167,7 +252,7 @@ -- | Just to avoid repetition and magic strings. cabalPackageName :: PackageName cabalPackageName =-    $(mkPackageName "Cabal")+    mkPackageName "Cabal"  -- | Deprecated implicit global project directory used when outside of a project. implicitGlobalProjectDirDeprecated :: Path Abs Dir -- ^ Stack root.@@ -244,11 +329,279 @@ defaultTerminalWidth :: Int defaultTerminalWidth = 100 --- | True if using Windows OS.-osIsWindows :: Bool-osIsWindows =-#ifdef WINDOWS-  True+relFileSetupHs :: Path Rel File+relFileSetupHs = $(mkRelFile "Setup.hs")++relFileSetupLhs :: Path Rel File+relFileSetupLhs = $(mkRelFile "Setup.lhs")++relFileHpackPackageConfig :: Path Rel File+relFileHpackPackageConfig = $(mkRelFile Hpack.packageConfig)++relDirGlobalAutogen :: Path Rel Dir+relDirGlobalAutogen = $(mkRelDir "global-autogen")++relDirAutogen :: Path Rel Dir+relDirAutogen = $(mkRelDir "autogen")++relDirLogs :: Path Rel Dir+relDirLogs = $(mkRelDir "logs")++relFileCabalMacrosH :: Path Rel File+relFileCabalMacrosH = $(mkRelFile "cabal_macros.h")++relDirBuild :: Path Rel Dir+relDirBuild = $(mkRelDir "build")++relDirBin :: Path Rel Dir+relDirBin = $(mkRelDir "bin")++relDirPantry :: Path Rel Dir+relDirPantry = $(mkRelDir "pantry")++relDirPrograms :: Path Rel Dir+relDirPrograms = $(mkRelDir "programs")++relDirUpperPrograms :: Path Rel Dir+relDirUpperPrograms = $(mkRelDir "Programs")++relDirStackProgName :: Path Rel Dir+relDirStackProgName = $(mkRelDir stackProgName)++relDirStackWork :: Path Rel Dir+relDirStackWork = $(mkRelDir ".stack-work")++relFileReadmeTxt :: Path Rel File+relFileReadmeTxt = $(mkRelFile "README.txt")++relDirScript :: Path Rel Dir+relDirScript = $(mkRelDir "script")++relFileConfigYaml :: Path Rel File+relFileConfigYaml = $(mkRelFile "config.yaml")++relDirSnapshots :: Path Rel Dir+relDirSnapshots = $(mkRelDir "snapshots")++relDirGlobalHints :: Path Rel Dir+relDirGlobalHints = $(mkRelDir "global-hints")++relFileGlobalHintsYaml :: Path Rel File+relFileGlobalHintsYaml = $(mkRelFile "global-hints.yaml")++relDirInstall :: Path Rel Dir+relDirInstall = $(mkRelDir "install")++relDirCompilerTools :: Path Rel Dir+relDirCompilerTools = $(mkRelDir "compiler-tools")++relDirHoogle :: Path Rel Dir+relDirHoogle = $(mkRelDir "hoogle")++relFileDatabaseHoo :: Path Rel File+relFileDatabaseHoo = $(mkRelFile "database.hoo")++relDirPkgdb :: Path Rel Dir+relDirPkgdb = $(mkRelDir "pkgdb")++relFileStorage :: Path Rel File+relFileStorage = $(mkRelFile "stack.sqlite3")++relDirLoadedSnapshotCache :: Path Rel Dir+relDirLoadedSnapshotCache = $(mkRelDir "loaded-snapshot-cached")++-- | Suffix applied to an installation root to get the bin dir+bindirSuffix :: Path Rel Dir+bindirSuffix = relDirBin++-- | Suffix applied to an installation root to get the doc dir+docDirSuffix :: Path Rel Dir+docDirSuffix = $(mkRelDir "doc")++relDirHpc :: Path Rel Dir+relDirHpc = $(mkRelDir "hpc")++relDirLib :: Path Rel Dir+relDirLib = $(mkRelDir "lib")++relDirShare :: Path Rel Dir+relDirShare = $(mkRelDir "share")++relDirLibexec :: Path Rel Dir+relDirLibexec = $(mkRelDir "libexec")++relDirEtc :: Path Rel Dir+relDirEtc = $(mkRelDir "etc")++setupGhciShimCode :: Builder+setupGhciShimCode = byteString $(do+    path <- makeRelativeToProject "src/setup-shim/StackSetupShim.hs"+    embedFile path)++relDirSetupExeCache :: Path Rel Dir+relDirSetupExeCache = $(mkRelDir "setup-exe-cache")++relDirSetupExeSrc :: Path Rel Dir+relDirSetupExeSrc = $(mkRelDir "setup-exe-src")++relFileConfigure :: Path Rel File+relFileConfigure = $(mkRelFile "configure")++relDirDist :: Path Rel Dir+relDirDist = $(mkRelDir "dist")++relFileSetupMacrosH :: Path Rel File+relFileSetupMacrosH = $(mkRelFile "setup_macros.h")++relDirSetup :: Path Rel Dir+relDirSetup = $(mkRelDir "setup")++relFileSetupLower :: Path Rel File+relFileSetupLower = $(mkRelFile "setup")++relDirMingw :: Path Rel Dir+relDirMingw = $(mkRelDir "mingw")++relDirMingw32 :: Path Rel Dir+relDirMingw32 = $(mkRelDir "mingw32")++relDirMingw64 :: Path Rel Dir+relDirMingw64 = $(mkRelDir "mingw64")++relDirLocal :: Path Rel Dir+relDirLocal = $(mkRelDir "local")++relDirUsr :: Path Rel Dir+relDirUsr = $(mkRelDir "usr")++relDirInclude :: Path Rel Dir+relDirInclude = $(mkRelDir "include")++relFileIndexHtml :: Path Rel File+relFileIndexHtml = $(mkRelFile "index.html")++relDirAll :: Path Rel Dir+relDirAll = $(mkRelDir "all")++relFilePackageCache :: Path Rel File+relFilePackageCache = $(mkRelFile "package.cache")++relFileDockerfile :: Path Rel File+relFileDockerfile = $(mkRelFile "Dockerfile")++relDirHaskellStackGhci :: Path Rel Dir+relDirHaskellStackGhci = $(mkRelDir "haskell-stack-ghci")++relFileGhciScript :: Path Rel File+relFileGhciScript = $(mkRelFile "ghci-script")++relDirCombined :: Path Rel Dir+relDirCombined = $(mkRelDir "combined")++relFileHpcIndexHtml :: Path Rel File+relFileHpcIndexHtml = $(mkRelFile "hpc_index.html")++relDirCustom :: Path Rel Dir+relDirCustom = $(mkRelDir "custom")++relDirPackageConfInplace :: Path Rel Dir+relDirPackageConfInplace = $(mkRelDir "package.conf.inplace")++relDirExtraTixFiles :: Path Rel Dir+relDirExtraTixFiles = $(mkRelDir "extra-tix-files")++relDirInstalledPackages :: Path Rel Dir+relDirInstalledPackages = $(mkRelDir "installed-packages")++backupUrlRelPath :: Path Rel File+backupUrlRelPath = $(mkRelFile "downloaded.template.file.hsfiles")++relDirDotLocal :: Path Rel Dir+relDirDotLocal = $(mkRelDir ".local")++relDirDotSsh :: Path Rel Dir+relDirDotSsh = $(mkRelDir ".ssh")++relDirDotStackProgName :: Path Rel Dir+relDirDotStackProgName = $(mkRelDir ('.' : stackProgName))++relDirUnderHome :: Path Rel Dir+relDirUnderHome = $(mkRelDir "_home")++relDirSrc :: Path Rel Dir+relDirSrc = $(mkRelDir "src")++relFileLibtinfoSo5 :: Path Rel File+relFileLibtinfoSo5 = $(mkRelFile "libtinfo.so.5")++relFileLibtinfoSo6 :: Path Rel File+relFileLibtinfoSo6 = $(mkRelFile "libtinfo.so.6")++relFileLibncurseswSo6 :: Path Rel File+relFileLibncurseswSo6 = $(mkRelFile "libncursesw.so.6")++relFileLibgmpSo10 :: Path Rel File+relFileLibgmpSo10 = $(mkRelFile "libgmp.so.10")++relFileLibgmpSo3 :: Path Rel File+relFileLibgmpSo3 = $(mkRelFile "libgmp.so.3")++relDirNewCabal :: Path Rel Dir+relDirNewCabal = $(mkRelDir "new-cabal")++relFileSetupExe :: Path Rel File+relFileSetupExe = $(mkRelFile "Setup.exe")++relFileSetupUpper :: Path Rel File+relFileSetupUpper = $(mkRelFile "Setup")++relFile7zexe :: Path Rel File+relFile7zexe = $(mkRelFile "7z.exe")++relFile7zdll :: Path Rel File+relFile7zdll = $(mkRelFile "7z.dll")++relFileMainHs :: Path Rel File+relFileMainHs = $(mkRelFile "Main.hs")++relFileStackDotExe :: Path Rel File+relFileStackDotExe = $(mkRelFile "stack.exe")++relFileStackDotTmpDotExe :: Path Rel File+relFileStackDotTmpDotExe = $(mkRelFile "stack.tmp.exe")++relFileStackDotTmp :: Path Rel File+relFileStackDotTmp = $(mkRelFile "stack.tmp")++relFileStack :: Path Rel File+relFileStack = $(mkRelFile "stack")++-- Technically, we should be consulting the user's current ghc,+-- but that would require loading up a BuildConfig.+ghcShowOptionsOutput :: [String]+ghcShowOptionsOutput =+  $(TH.runIO (readProcess "ghc" ["--show-options"] "") >>= TH.lift . lines)++-- | Relative path inside a GHC repo to the Hadrian build batch script+hadrianCmdWindows :: Path Rel File+hadrianCmdWindows = $(mkRelFile "hadrian/build.stack.bat")++-- | Relative path inside a GHC repo to the Hadrian build shell script+hadrianCmdPosix :: Path Rel File+hadrianCmdPosix = $(mkRelFile "hadrian/build.stack.sh")++-- | Used in Stack.Setup for detecting libtinfo, see comments at use site+usrLibDirs :: [Path Abs Dir]+#if WINDOWS+usrLibDirs = [] #else-  False+usrLibDirs = [$(mkAbsDir "/usr/lib"),$(mkAbsDir "/usr/lib64")] #endif++-- | Relative file path for a temporary GHC environment file for tests+testGhcEnvRelFile :: Path Rel File+testGhcEnvRelFile = $(mkRelFile "test-ghc-env")++-- | File inside a dist directory to use for locking+relFileBuildLock :: Path Rel File+relFileBuildLock = $(mkRelFile "build-lock")
src/Stack/Constants/Config.hs view
@@ -3,11 +3,11 @@ {-# LANGUAGE OverloadedStrings #-} module Stack.Constants.Config   ( distDirFromDir+  , rootDistDirFromDir   , workDirFromDir   , distRelativeDir   , imageStagingDir   , projectDockerSandboxDir-  , configCacheFile   , configCabalMod   , buildCachesDir   , testSuccessFile@@ -23,7 +23,6 @@ import Stack.Constants import Stack.Types.Compiler import Stack.Types.Config-import Stack.Types.PackageIdentifier import Path  -- | Output .o/.hi directory.@@ -67,15 +66,6 @@         (</> $(mkRelFile "stack-test-built"))         (distDirFromDir dir) --- | The filename used for dirtiness check of config.-configCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env)-                => Path Abs Dir      -- ^ Package directory.-                -> m (Path Abs File)-configCacheFile dir =-    liftM-        (</> $(mkRelFile "stack-config-cache"))-        (distDirFromDir dir)- -- | The filename used for modification check of .cabal configCabalMod :: (MonadThrow m, MonadReader env m, HasEnvConfig env)                => Path Abs Dir      -- ^ Package directory.@@ -106,8 +96,26 @@ distDirFromDir fp =     liftM (fp </>) distRelativeDir +-- | The directory containing all dist directories, including all+-- different GHC/Cabal combos.+rootDistDirFromDir+  :: (MonadReader env m, HasConfig env)+  => Path Abs Dir+  -> m (Path Abs Dir)+rootDistDirFromDir fp =+    liftM (fp </>) rootDistRelativeDir++-- | Relative directory to the top dist directory, containing+-- individual GHC/Cabal combo as subdirs.+rootDistRelativeDir+  :: (MonadReader env m, HasConfig env)+  => m (Path Rel Dir)+rootDistRelativeDir = do+    workDir <- view workDirL+    return $ workDir </> $(mkRelDir "dist")+ -- | Package's working directory.-workDirFromDir :: (MonadReader env m, HasEnvConfig env)+workDirFromDir :: (MonadReader env m, HasConfig env)                => Path Abs Dir                -> m (Path Abs Dir) workDirFromDir fp = view $ workDirL.to (fp </>)@@ -130,11 +138,8 @@         packageIdentifierString $         PackageIdentifier cabalPackageName cabalPkgVer     platformAndCabal <- useShaPathOnWindows (platform </> envDir)-    workDir <- view workDirL-    return $-        workDir </>-        $(mkRelDir "dist") </>-        platformAndCabal+    allDist <- rootDistRelativeDir+    return $ allDist </> platformAndCabal  -- | Docker sandbox from project root. projectDockerSandboxDir :: (MonadReader env m, HasConfig env)
src/Stack/Coverage.hs view
@@ -4,9 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE LambdaCase            #-} {-# LANGUAGE TupleSections         #-}  -- | Generate HPC (Haskell Program Coverage) reports@@ -27,26 +25,23 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T-import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT+import           Distribution.Version (mkVersion) import           Path import           Path.Extra (toFilePathNoTrailingSep) import           Path.IO import           Stack.Build.Target-import           Stack.Config (getLocalPackages)+import           Stack.Constants import           Stack.Constants.Config import           Stack.Package-import           Stack.PrettyPrint import           Stack.Types.Compiler import           Stack.Types.Config import           Stack.Types.NamedComponent import           Stack.Types.Package-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Runner-import           Stack.Types.Version+import           Stack.Types.SourceMap import           System.FilePath (isPathSeparator) import qualified RIO+import           RIO.PrettyPrint import           RIO.Process import           Trace.Hpc.Tix import           Web.Browser (openBrowser)@@ -60,10 +55,10 @@ -- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is -- present. updateTixFile :: HasEnvConfig env => PackageName -> Path Abs File -> String -> RIO env ()-updateTixFile pkgName tixSrc testName = do+updateTixFile pkgName' tixSrc testName = do     exists <- doesFileExist tixSrc     when exists $ do-        tixDest <- tixFilePath pkgName testName+        tixDest <- tixFilePath pkgName' testName         liftIO $ ignoringAbsence (removeFile tixDest)         ensureDir (parent tixDest)         -- Remove exe modules because they are problematic. This could be revisited if there's a GHC@@ -81,17 +76,17 @@  -- | Get the directory used for hpc reports for the given pkgId. hpcPkgPath :: HasEnvConfig env => PackageName -> RIO env (Path Abs Dir)-hpcPkgPath pkgName = do+hpcPkgPath pkgName' = do     outputDir <- hpcReportDir-    pkgNameRel <- parseRelDir (packageNameString pkgName)+    pkgNameRel <- parseRelDir (packageNameString pkgName')     return (outputDir </> pkgNameRel)  -- | Get the tix file location, given the name of the file (without extension), and the package -- identifier string. tixFilePath :: HasEnvConfig env             => PackageName -> String -> RIO env (Path Abs File)-tixFilePath pkgName testName = do-    pkgPath <- hpcPkgPath pkgName+tixFilePath pkgName' testName = do+    pkgPath <- hpcPkgPath pkgName'     tixRel <- parseRelFile (testName ++ "/" ++ testName ++ ".tix")     return (pkgPath </> tixRel) @@ -102,7 +97,7 @@     compilerVersion <- view actualCompilerVersionL     -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See     -- https://github.com/commercialhaskell/stack/issues/785-    let pkgName = packageNameText (packageName package)+    let pkgName' = T.pack $ packageNameString (packageName package)         pkgId = packageIdentifierString (packageIdentifier package)         ghcVersion = getGhcVersion compilerVersion         hasLibrary =@@ -112,7 +107,7 @@         internalLibs = packageInternalLibraries package     eincludeName <-         -- Pre-7.8 uses plain PKG-version in tix files.-        if ghcVersion < $(mkVersion "7.10") then return $ Right $ Just [pkgId]+        if ghcVersion < mkVersion [7, 10] then return $ Right $ Just [pkgId]         -- We don't expect to find a package key if there is no library.         else if not hasLibrary && Set.null internalLibs then return $ Right Nothing         -- Look in the inplace DB for the package key.@@ -120,7 +115,7 @@         else do             -- GHC 8.0 uses package id instead of package key.             -- See https://github.com/commercialhaskell/stack/issues/2424-            let hpcNameField = if ghcVersion >= $(mkVersion "8.0") then "id" else "key"+            let hpcNameField = if ghcVersion >= mkVersion [8, 0] then "id" else "key"             eincludeName <- findPackageFieldForBuiltPackage pkgDir (packageIdentifier package) internalLibs hpcNameField             case eincludeName of                 Left err -> do@@ -129,7 +124,7 @@                 Right includeNames -> return $ Right $ Just $ map T.unpack includeNames     forM_ tests $ \testName -> do         tixSrc <- tixFilePath (packageName package) (T.unpack testName)-        let report = "coverage report for " <> pkgName <> "'s test-suite \"" <> testName <> "\""+        let report = "coverage report for " <> pkgName' <> "'s test-suite \"" <> testName <> "\""             reportDir = parent tixSrc         case eincludeName of             Left err -> generateHpcErrorReport reportDir (RIO.display (sanitize (T.unpack err)))@@ -140,7 +135,7 @@                         Just includeNames -> "--include" : intersperse "--include" (map (\n -> n ++ ":") includeNames)                         Nothing -> []                 mreportPath <- generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs-                forM_ mreportPath (displayReportPath report . display)+                forM_ mreportPath (displayReportPath report . pretty)  generateHpcReportInternal :: HasEnvConfig env                           => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String]@@ -165,7 +160,7 @@             -- Directories for .mix files.             hpcRelDir <- hpcRelativeDir             -- Compute arguments used for both "hpc markup" and "hpc report".-            pkgDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages+            pkgDirs <- view $ buildConfigL.to (map ppRoot . Map.elems . smwProject . bcSMWanted)             let args =                     -- Use index files from all packages (allows cross-package coverage results).                     concatMap (\x -> ["--srcdir", toFilePathNoTrailingSep x]) pkgDirs ++@@ -196,7 +191,7 @@                     generateHpcErrorReport reportDir (msg True)                     return Nothing                 else do-                    let reportPath = reportDir </> $(mkRelFile "hpc_index.html")+                    let reportPath = reportDir </> relFileHpcIndexHtml                     -- Print output, stripping @\r@ characters because Windows.                     forM_ outputLines (logInfo . displayBytesUtf8)                     -- Generate the markup.@@ -217,9 +212,8 @@     } deriving (Show)  generateHpcReportForTargets :: HasEnvConfig env-                            => HpcReportOpts -> RIO env ()-generateHpcReportForTargets opts = do-    let (tixFiles, targetNames) = partition (".tix" `T.isSuffixOf`) (hroptsInputs opts)+                            => HpcReportOpts -> [Text] -> [Text] -> RIO env ()+generateHpcReportForTargets opts tixFiles targetNames = do     targetTixFiles <-          -- When there aren't any package component arguments, and --all          -- isn't passed, default to not considering any targets.@@ -228,13 +222,10 @@          else do              when (hroptsAll opts && not (null targetNames)) $                  logWarn $ "Since --all is used, it is redundant to specify these targets: " <> displayShow targetNames-             (_,_,targets) <- parseTargets-                 AllowNoTargets-                 defaultBuildOptsCLI-                    { boptsCLITargets = if hroptsAll opts then [] else targetNames }+             targets <- view $ envConfigL.to envConfigSourceMap.to smTargets.to smtTargets              liftM concat $ forM (Map.toList targets) $ \(name, target) ->                  case target of-                     TargetAll Dependency -> throwString $+                     TargetAll PTDependency -> throwString $                          "Error: Expected a local package, but " ++                          packageNameString name ++                          " is either an extra-dep or in the snapshot."@@ -248,7 +239,7 @@                                      "Can't specify anything except test-suites as hpc report targets (" ++                                      packageNameString name ++                                      " is used with a non test-suite target)"-                     TargetAll ProjectPackage -> do+                     TargetAll PTProject -> do                          pkgPath <- hpcPkgPath name                          exists <- doesDirExist pkgPath                          if exists@@ -263,7 +254,7 @@         throwString "Not generating combined report, because no targets or tix files are specified."     outputDir <- hpcReportDir     reportDir <- case hroptsDestDir opts of-        Nothing -> return (outputDir </> $(mkRelDir "combined/custom"))+        Nothing -> return (outputDir </> relDirCombined </> relDirCustom)         Just destDir -> do             dest <- resolveDir' destDir             ensureDir dest@@ -273,9 +264,9 @@     forM_ mreportPath $ \reportPath ->         if hroptsOpenBrowser opts             then do-                prettyInfo $ "Opening" <+> display reportPath <+> "in the browser."+                prettyInfo $ "Opening" <+> pretty reportPath <+> "in the browser."                 void $ liftIO $ openBrowser (toFilePath reportPath)-            else displayReportPath report (display reportPath)+            else displayReportPath report (pretty reportPath)  generateHpcUnifiedReport :: HasEnvConfig env => RIO env () generateHpcUnifiedReport = do@@ -289,7 +280,7 @@             return (filter ((".tix" `isSuffixOf`) . toFilePath) files)     extraTixFiles <- findExtraTixFiles     let tixFiles = tixFiles0  ++ extraTixFiles-        reportDir = outputDir </> $(mkRelDir "combined/all")+        reportDir = outputDir </> relDirCombined </> relDirAll     if length tixFiles < 2         then logInfo $             (if null tixFiles then "No tix files" else "Only one tix file") <>@@ -299,7 +290,7 @@         else do             let report = "unified report"             mreportPath <- generateUnionReport report reportDir tixFiles-            forM_ mreportPath (displayReportPath report . display)+            forM_ mreportPath (displayReportPath report . pretty)  generateUnionReport :: HasEnvConfig env                     => Text -> Path Abs Dir -> [Path Abs File]@@ -344,13 +335,13 @@ generateHpcMarkupIndex :: HasEnvConfig env => RIO env () generateHpcMarkupIndex = do     outputDir <- hpcReportDir-    let outputFile = outputDir </> $(mkRelFile "index.html")+    let outputFile = outputDir </> relFileIndexHtml     ensureDir outputDir     (dirs, _) <- listDir outputDir     rows <- liftM (catMaybes . concat) $ forM dirs $ \dir -> do         (subdirs, _) <- listDir dir         forM subdirs $ \subdir -> do-            let indexPath = subdir </> $(mkRelFile "hpc_index.html")+            let indexPath = subdir </> relFileHpcIndexHtml             exists' <- doesFileExist indexPath             if not exists' then return Nothing else do                 relPath <- stripProperPrefix outputDir indexPath@@ -365,31 +356,28 @@                   , pathToHtml testsuite                   , "</a></td></tr>"                   ]-    liftIO $ T.writeFile (toFilePath outputFile) $ T.concat $-        [ "<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">"+    writeBinaryFileAtomic outputFile $+        "<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">" <>         -- Part of the css from HPC's output HTML-        , "<style type=\"text/css\">"-        , "table.dashboard { border-collapse: collapse; border: solid 1px black }"-        , ".dashboard td { border: solid 1px black }"-        , ".dashboard th { border: solid 1px black }"-        , "</style>"-        , "</head>"-        , "<body>"-        ] +++        "<style type=\"text/css\">" <>+        "table.dashboard { border-collapse: collapse; border: solid 1px black }" <>+        ".dashboard td { border: solid 1px black }" <>+        ".dashboard th { border: solid 1px black }" <>+        "</style>" <>+        "</head>" <>+        "<body>" <>         (if null rows             then-                [ "<b>No hpc_index.html files found in \""-                , pathToHtml outputDir-                , "\".</b>"-                ]+                "<b>No hpc_index.html files found in \"" <>+                encodeUtf8Builder (pathToHtml outputDir) <>+                "\".</b>"             else-                [ "<table class=\"dashboard\" width=\"100%\" boder=\"1\"><tbody>"-                , "<p><b>NOTE: This is merely a listing of the html files found in the coverage reports directory.  Some of these reports may be old.</b></p>"-                , "<tr><th>Package</th><th>TestSuite</th><th>Modification Time</th></tr>"-                ] ++-                rows ++-                ["</tbody></table>"]) ++-        ["</body></html>"]+                "<table class=\"dashboard\" width=\"100%\" boder=\"1\"><tbody>" <>+                "<p><b>NOTE: This is merely a listing of the html files found in the coverage reports directory.  Some of these reports may be old.</b></p>" <>+                "<tr><th>Package</th><th>TestSuite</th><th>Modification Time</th></tr>" <>+                foldMap encodeUtf8Builder rows <>+                "</tbody></table>") <>+        "</body></html>"     unless (null rows) $         logInfo $ "\nAn index of the generated HTML coverage reports is available at " <>             fromString (toFilePath outputFile)@@ -397,7 +385,7 @@ generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Utf8Builder -> m () generateHpcErrorReport dir err = do     ensureDir dir-    let fp = toFilePath (dir </> $(mkRelFile "hpc_index.html"))+    let fp = toFilePath (dir </> relFileHpcIndexHtml)     writeFileUtf8Builder fp $         "<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\"></head><body>" <>         "<h1>HPC Report Generation Error</h1>" <>@@ -433,16 +421,16 @@     -> RIO env (Either Text [Text]) findPackageFieldForBuiltPackage pkgDir pkgId internalLibs field = do     distDir <- distDirFromDir pkgDir-    let inplaceDir = distDir </> $(mkRelDir "package.conf.inplace")+    let inplaceDir = distDir </> relDirPackageConfInplace         pkgIdStr = packageIdentifierString pkgId         notFoundErr = return $ Left $ "Failed to find package key for " <> T.pack pkgIdStr         extractField path = do-            contents <- liftIO $ T.readFile (toFilePath path)+            contents <- readFileUtf8 (toFilePath path)             case asum (map (T.stripPrefix (field <> ": ")) (T.lines contents)) of                 Just result -> return $ Right result                 Nothing -> notFoundErr     cabalVer <- view cabalVersionL-    if cabalVer < $(mkVersion "1.24")+    if cabalVer < mkVersion [1, 24]         then do             -- here we don't need to handle internal libs             path <- liftM (inplaceDir </>) $ parseRelFile (pkgIdStr ++ "-inplace.conf")@@ -482,15 +470,15 @@             else return $ Left $ "Multiple files matching " <> T.pack (pkgIdStr ++ "-*.conf") <> " found in " <>                     T.pack (toFilePath inplaceDir) <> ". Maybe try 'stack clean' on this package?" -displayReportPath :: (HasRunner env)-                  => Text -> AnsiDoc -> RIO env ()+displayReportPath :: (HasTerm env)+                  => Text -> StyleDoc -> RIO env () displayReportPath report reportPath =      prettyInfo $ "The" <+> fromString (T.unpack report) <+> "is available at" <+> reportPath  findExtraTixFiles :: HasEnvConfig env => RIO env [Path Abs File] findExtraTixFiles = do     outputDir <- hpcReportDir-    let dir = outputDir </> $(mkRelDir "extra-tix-files")+    let dir = outputDir </> relDirExtraTixFiles     dirExists <- doesDirExist dir     if dirExists         then do
+ src/Stack/DefaultColorWhen.hs view
@@ -0,0 +1,27 @@+module Stack.DefaultColorWhen+  ( defaultColorWhen+  ) where++import Stack.Prelude (stdout)+import Stack.Types.Config (ColorWhen (ColorAuto, ColorNever))++import System.Console.ANSI (hSupportsANSIWithoutEmulation)+import System.Environment (lookupEnv)++-- | The default adopts the standard proposed at http://no-color.org/, that+-- color should not be added by default if the @NO_COLOR@ environment variable+-- is present.+defaultColorWhen :: IO ColorWhen+defaultColorWhen = do+  -- On Windows, 'hSupportsANSIWithoutEmulation' has the side effect of enabling+  -- ANSI for ANSI-capable native (ConHost) terminals, if not already+  -- ANSI-enabled. Consequently, it is actioned even if @NO_COLOR@ might exist,+  -- as @NO_COLOR@ might be overridden in a yaml configuration file or at the+  -- command line.+  supportsANSI <- hSupportsANSIWithoutEmulation stdout+  mIsNoColor <- lookupEnv "NO_COLOR"+  return $ case mIsNoColor of+    Just _ -> ColorNever+    _      -> case supportsANSI of+      Just False -> ColorNever+      _          -> ColorAuto
src/Stack/Docker.hs view
@@ -1,48 +1,46 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP, ConstraintKinds, DeriveDataTypeable, FlexibleContexts, MultiWayIf, NamedFieldPuns,-             OverloadedStrings, PackageImports, RankNTypes, RecordWildCards, ScopedTypeVariables,-             TemplateHaskell, TupleSections #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Run commands in Docker containers module Stack.Docker-  (cleanup-  ,CleanupOpts(..)-  ,CleanupAction(..)-  ,dockerCleanupCmdName-  ,dockerCmdName+  (dockerCmdName   ,dockerHelpOptName   ,dockerPullCmdName   ,entrypoint   ,preventInContainer   ,pull-  ,reexecWithOptionalContainer   ,reset   ,reExecArgName   ,StackDockerException(..)+  ,getProjectRoot+  ,runContainerAndExit   ) where  import           Stack.Prelude-import           Control.Monad.Writer (execWriter,runWriter,tell) import qualified Crypto.Hash as Hash (Digest, MD5, hash)-import           Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)-import           Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString)+import           Pantry.Internal.AesonExtended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as LBS-import           Data.Char (isSpace,toUpper,isAscii,isDigit)+import           Data.Char (isAscii,isDigit) import           Data.Conduit.List (sinkNull) import           Data.Conduit.Process.Typed hiding (proc)-import           Data.List (dropWhileEnd,intercalate,isPrefixOf,isInfixOf)+import           Data.List (dropWhileEnd,isPrefixOf,isInfixOf) import           Data.List.Extra (trim) import qualified Data.Map.Strict as Map-import           Data.Ord (Down(..))-import           Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T-import           Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..))+import           Data.Time (UTCTime) import           Data.Version (showVersion)-import           GHC.Exts (sortWith)-import           Lens.Micro (set)+import           Distribution.Version (mkVersion) import           Path import           Path.Extra (toFilePathNoTrailingSep) import           Path.IO hiding (canonicalizePath)@@ -50,172 +48,112 @@ import           Stack.Config (getInContainer) import           Stack.Constants import           Stack.Constants.Config-import           Stack.Docker.GlobalDB-import           Stack.PackageIndex-import           Stack.Types.PackageIndex-import           Stack.Types.Runner+import           Stack.Setup (ensureDockerStackExe)+import           Stack.Storage (loadDockerImageExeCache,saveDockerImageExeCache) import           Stack.Types.Version import           Stack.Types.Config import           Stack.Types.Docker-import           Stack.Setup (ensureDockerStackExe)-import           System.Directory (canonicalizePath,getHomeDirectory) import           System.Environment (getEnv,getEnvironment,getProgName,getArgs,getExecutablePath)-import           System.Exit (exitSuccess, exitWith, ExitCode(..)) import qualified System.FilePath as FP-import           System.IO (stderr,stdin,stdout)+import           System.IO (stderr,stdin) 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.PagerEditor (editByteString)+import           System.Terminal (hIsTerminalDeviceOrMinTTY) import           RIO.Process-import           Text.Printf (printf)  #ifndef WINDOWS import           System.Posix.Signals import qualified System.Posix.User as PosixUser #endif --- | If Docker is enabled, re-runs the currently running OS command in a Docker container.--- Otherwise, runs the inner action.------ This takes an optional release action which should be taken IFF control is--- transferring away from the current process to the intra-container one.  The main use--- 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-    :: HasConfig env-    => Maybe (Path Abs Dir)-    -> Maybe (RIO env ())-    -> IO ()-    -> Maybe (RIO env ())-    -> Maybe (RIO env ())-    -> RIO env ()-reexecWithOptionalContainer mprojectRoot =-    execWithOptionalContainer mprojectRoot getCmdArgs+-- | Function to get command and arguments to run in Docker container+getCmdArgs+  :: HasConfig env+  => DockerOpts+  -> Inspect+  -> Bool+  -> RIO env (FilePath,[String],[(String,String)],[Mount])+getCmdArgs docker imageInfo isRemoteDocker = do+    config <- view configL+    deUser <-+        if fromMaybe (not isRemoteDocker) (dockerSetUser docker)+            then liftIO $ do+              duUid <- User.getEffectiveUserID+              duGid <- User.getEffectiveGroupID+              duGroups <- nubOrd <$> User.getGroups+              duUmask <- Files.setFileCreationMask 0o022+              -- Only way to get old umask seems to be to change it, so set it back afterward+              _ <- Files.setFileCreationMask duUmask+              return (Just DockerUser{..})+            else return Nothing+    args <-+        fmap+            (["--" ++ reExecArgName ++ "=" ++ showVersion Meta.version+             ,"--" ++ dockerEntrypointArgName+             ,show DockerEntrypoint{..}] ++)+            (liftIO getArgs)+    case dockerStackExe (configDocker config) of+        Just DockerStackExeHost+          | configPlatform config == dockerContainerPlatform -> do+              exePath <- resolveFile' =<< liftIO getExecutablePath+              cmdArgs args exePath+          | otherwise -> throwIO UnsupportedStackExeHostPlatformException+        Just DockerStackExeImage -> do+            progName <- liftIO getProgName+            return (FP.takeBaseName progName, args, [], [])+        Just (DockerStackExePath path) -> do+            cmdArgs args path+        Just DockerStackExeDownload -> exeDownload args+        Nothing+          | configPlatform config == dockerContainerPlatform -> do+              (exePath,exeTimestamp,misCompatible) <-+                  do exePath <- resolveFile' =<< liftIO getExecutablePath+                     exeTimestamp <- getModificationTime exePath+                     isKnown <-+                         loadDockerImageExeCache+                             (iiId imageInfo)+                             exePath+                             exeTimestamp+                     return (exePath, exeTimestamp, isKnown)+              case misCompatible of+                  Just True -> cmdArgs args exePath+                  Just False -> exeDownload args+                  Nothing -> do+                      e <-+                          try $+                          sinkProcessStderrStdout+                              "docker"+                              [ "run"+                              , "-v"+                              , toFilePath exePath ++ ":" ++ "/tmp/stack"+                              , T.unpack (iiId imageInfo)+                              , "/tmp/stack"+                              , "--version"]+                              sinkNull+                              sinkNull+                      let compatible =+                              case e of+                                  Left ExitCodeException{} -> False+                                  Right _ -> True+                      saveDockerImageExeCache+                          (iiId imageInfo)+                          exePath+                          exeTimestamp+                          compatible+                      if compatible+                          then cmdArgs args exePath+                          else exeDownload args+        Nothing -> exeDownload args   where-    getCmdArgs docker imageInfo isRemoteDocker = do-        config <- view configL-        deUser <--            if fromMaybe (not isRemoteDocker) (dockerSetUser docker)-                then liftIO $ do-                  duUid <- User.getEffectiveUserID-                  duGid <- User.getEffectiveGroupID-                  duGroups <- nubOrd <$> User.getGroups-                  duUmask <- Files.setFileCreationMask 0o022-                  -- Only way to get old umask seems to be to change it, so set it back afterward-                  _ <- Files.setFileCreationMask duUmask-                  return (Just DockerUser{..})-                else return Nothing-        args <--            fmap-                (["--" ++ reExecArgName ++ "=" ++ showVersion Meta.version-                 ,"--" ++ dockerEntrypointArgName-                 ,show DockerEntrypoint{..}] ++)-                (liftIO getArgs)-        case dockerStackExe (configDocker config) of-            Just DockerStackExeHost-              | configPlatform config == dockerContainerPlatform -> do-                  exePath <- liftIO getExecutablePath-                  cmdArgs args exePath-              | otherwise -> throwIO UnsupportedStackExeHostPlatformException-            Just DockerStackExeImage -> do-                progName <- liftIO getProgName-                return (FP.takeBaseName progName, args, [], [])-            Just (DockerStackExePath path) -> do-                exePath <- liftIO $ canonicalizePath (toFilePath path)-                cmdArgs args exePath-            Just DockerStackExeDownload -> exeDownload args-            Nothing-              | configPlatform config == dockerContainerPlatform -> do-                  (exePath,exeTimestamp,misCompatible) <--                      liftIO $-                      do exePath <- liftIO getExecutablePath-                         exeTimestamp <- resolveFile' exePath >>= getModificationTime-                         isKnown <--                             liftIO $-                             getDockerImageExe-                                 config-                                 (iiId imageInfo)-                                 exePath-                                 exeTimestamp-                         return (exePath, exeTimestamp, isKnown)-                  case misCompatible of-                      Just True -> cmdArgs args exePath-                      Just False -> exeDownload args-                      Nothing -> do-                          e <--                              try $-                              sinkProcessStderrStdout-                                  "docker"-                                  [ "run"-                                  , "-v"-                                  , exePath ++ ":" ++ "/tmp/stack"-                                  , iiId imageInfo-                                  , "/tmp/stack"-                                  , "--version"]-                                  sinkNull-                                  sinkNull-                          let compatible =-                                  case e of-                                      Left (ProcessExitedUnsuccessfully _ _) ->-                                          False-                                      Right _ -> True-                          liftIO $-                              setDockerImageExe-                                  config-                                  (iiId imageInfo)-                                  exePath-                                  exeTimestamp-                                  compatible-                          if compatible-                              then cmdArgs args exePath-                              else exeDownload args-            Nothing -> exeDownload args     exeDownload args = do         exePath <- ensureDockerStackExe dockerContainerPlatform-        cmdArgs args (toFilePath exePath)+        cmdArgs args exePath     cmdArgs args exePath = do-        let mountPath = hostBinDir FP.</> FP.takeBaseName exePath-        return (mountPath, args, [], [Mount exePath mountPath])---- | If Docker is enabled, re-runs the OS command returned by the second argument in a--- Docker container.  Otherwise, runs the inner action.------ This takes an optional release action just like `reexecWithOptionalContainer`.-execWithOptionalContainer-    :: HasConfig env-    => Maybe (Path Abs Dir)-    -> GetCmdArgs env-    -> Maybe (RIO env ())-    -> IO ()-    -> Maybe (RIO env ())-    -> Maybe (RIO env ())-    -> RIO env ()-execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease =-  do config <- view configL-     inContainer <- getInContainer-     isReExec <- view reExecL-     if | inContainer && not isReExec && (isJust mbefore || isJust mafter) ->-            throwIO OnlyOnHostException-        | inContainer ->-            liftIO (do inner-                       System.Exit.exitSuccess)-        | not (dockerEnable (configDocker config)) ->-            do fromMaybeAction mbefore-               liftIO inner-               fromMaybeAction mafter-               liftIO System.Exit.exitSuccess-        | otherwise ->-            do fromMaybeAction mrelease-               runContainerAndExit-                 getCmdArgs-                 mprojectRoot-                 (fromMaybeAction mbefore)-                 (fromMaybeAction mafter)-  where-    fromMaybeAction Nothing = return ()-    fromMaybeAction (Just hook) = hook+        exeBase <- exePath -<.> ""+        let mountPath = hostBinDir FP.</> toFilePath (filename exeBase)+        return (mountPath, args, [], [Mount (toFilePath exePath) mountPath])  -- | Error if running in a container. preventInContainer :: MonadIO m => m () -> m ()@@ -226,17 +164,8 @@         else inner  -- | Run a command in a new Docker container, then exit the process.-runContainerAndExit-  :: HasConfig env-  => GetCmdArgs env-  -> Maybe (Path Abs Dir) -- ^ Project root (maybe)-  -> RIO env ()  -- ^ Action to run before-  -> RIO env ()  -- ^ Action to run after-  -> RIO env ()-runContainerAndExit getCmdArgs-                    mprojectRoot-                    before-                    after = do+runContainerAndExit :: HasConfig env => RIO env void+runContainerAndExit = do      config <- view configL      let docker = configDocker config      checkDockerVersion docker@@ -245,7 +174,7 @@        <$> getEnvironment        <*> hIsTerminalDeviceOrMinTTY stdin        <*> hIsTerminalDeviceOrMinTTY stderr-       <*> (parseAbsDir =<< getHomeDirectory)+       <*> getHomeDir      isStdoutTerminal <- view terminalL      let dockerHost = lookup "DOCKER_HOST" env          dockerCertPath = lookup "DOCKER_CERT_PATH" env@@ -254,7 +183,7 @@          msshAuthSock = lookup "SSH_AUTH_SOCK" env          muserEnv = lookup "USER" env          isRemoteDocker = maybe False (isPrefixOf "tcp://") dockerHost-         image = dockerImage docker+     image <- either throwIO pure (dockerImage docker)      when (isRemoteDocker &&            maybe False (isInfixOf "boot2docker") dockerCertPath)           (logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.")@@ -269,6 +198,7 @@                   Just ii2 -> return ii2                   Nothing -> throwM (InspectFailedException image)          | otherwise -> throwM (NotPulledException image)+     projectRoot <- getProjectRoot      sandboxDir <- projectDockerSandboxDir projectRoot      let ImageConfig {..} = iiConfig          imageEnvVars = map (break (== '=')) icEnv@@ -284,17 +214,17 @@                          -- This is fixed in Docker 1.9.1, but will leave the workaround                          -- in place for now, for users who haven't upgraded yet.                          (isTerm || (isNothing bamboo && isNothing jenkins))-     hostBinDirPath <- parseAbsDir hostBinDir+     let mpath = T.pack <$> lookupImageEnv "PATH" imageEnvVars+     when (isNothing mpath) $ do+       logWarn "The Docker image does not set the PATH env var"+       logWarn "This will likely fail, see https://github.com/commercialhaskell/stack/issues/2742"      newPathEnv <- either throwM return $ augmentPath-                      ( toFilePath <$>-                      [ hostBinDirPath-                      , sandboxHomeDir </> $(mkRelDir ".local/bin")])-                      (T.pack <$> lookupImageEnv "PATH" imageEnvVars)+                      [ hostBinDir+                      , toFilePath (sandboxHomeDir </> relDirDotLocal </> relDirBin)]+                      mpath      (cmnd,args,envVars,extraMount) <- getCmdArgs docker imageInfo isRemoteDocker      pwd <- getCurrentDir-     liftIO-       (do updateDockerImageLastUsed config iiId (toFilePath projectRoot)-           mapM_ ensureDir [sandboxHomeDir, stackRoot])+     liftIO $ 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@@ -308,6 +238,7 @@              (Files.createSymbolicLink                  (toFilePathNoTrailingSep sshDir)                  (toFilePathNoTrailingSep (sandboxHomeDir </> sshRelDir))))+     let mountSuffix = maybe "" (":" ++) (dockerMountMode docker)      containerID <- withWorkingDir (toFilePath projectRoot) $ trim . decodeUtf8 <$> readDockerProcess        (concat          [["create"@@ -318,10 +249,10 @@           ,"-e","HOME=" ++ toFilePathNoTrailingSep sandboxHomeDir           ,"-e","PATH=" ++ T.unpack newPathEnv           ,"-e","PWD=" ++ toFilePathNoTrailingSep pwd-          ,"-v",toFilePathNoTrailingSep homeDir ++ ":" ++ toFilePathNoTrailingSep homeDir-          ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot-          ,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot-          ,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxHomeDir+          ,"-v",toFilePathNoTrailingSep homeDir ++ ":" ++ toFilePathNoTrailingSep homeDir ++ mountSuffix+          ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot ++ mountSuffix+          ,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot ++ mountSuffix+          ,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxHomeDir ++ mountSuffix           ,"-w",toFilePathNoTrailingSep pwd]          ,case muserEnv of             Nothing -> []@@ -337,7 +268,7 @@                (icEntrypoint == ["/usr/local/sbin/docker-entrypoint"] ||                  icEntrypoint == ["/root/entrypoint.sh"])]          ,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars-         ,concatMap mountArg (extraMount ++ dockerMount docker)+         ,concatMap (mountArg mountSuffix) (extraMount ++ dockerMount docker)          ,concatMap (\nv -> ["-e", nv]) (dockerEnv docker)          ,case dockerContainerName docker of             Just name -> ["--name=" ++ name]@@ -348,7 +279,8 @@          ,[image]          ,[cmnd]          ,args])-     before+-- MSS 2018-08-30 can the CPP below be removed entirely, and instead exec the+-- `docker` process so that it can handle the signals directly? #ifndef WINDOWS      run <- askRunInIO      oldHandlers <- forM [sigINT,sigABRT,sigHUP,sigPIPE,sigTERM,sigUSR1,sigUSR2] $ \sig -> do@@ -376,9 +308,8 @@ #endif          )      case e of-       Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (System.Exit.exitWith ec)-       Right () -> do after-                      liftIO System.Exit.exitSuccess+       Left ExitCodeException{eceExitCode} -> exitWith eceExitCode+       Right () -> exitSuccess   where     -- This is using a hash of the Docker repository (without tag or digest) to ensure     -- binaries/libraries aren't shared between Docker and host (or incompatible Docker images)@@ -388,241 +319,9 @@       case lookup name vars of         Just ('=':val) -> Just val         _ -> Nothing-    mountArg (Mount host container) = ["-v",host ++ ":" ++ container]-    projectRoot = fromMaybeProjectRoot mprojectRoot-    sshRelDir = $(mkRelDir ".ssh/")---- | Clean-up old docker images and containers.-cleanup :: HasConfig env => CleanupOpts -> RIO env ()-cleanup opts = do-     config <- view configL-     let docker = configDocker config-     checkDockerVersion docker-     imagesOut <- readDockerProcess ["images","--no-trunc","-f","dangling=false"]-     danglingImagesOut <- readDockerProcess ["images","--no-trunc","-f","dangling=true"]-     runningContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=running"]-     restartingContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=restarting"]-     exitedContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=exited"]-     pausedContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=paused"]-     let imageRepos = parseImagesOut imagesOut-         danglingImageHashes = Map.keys (parseImagesOut danglingImagesOut)-         runningContainers = parseContainersOut runningContainersOut ++-                             parseContainersOut restartingContainersOut-         stoppedContainers = parseContainersOut exitedContainersOut ++-                             parseContainersOut pausedContainersOut-     inspectMap <- inspects (Map.keys imageRepos ++-                             danglingImageHashes ++-                             map fst stoppedContainers ++-                             map fst runningContainers)-     (imagesLastUsed,curTime) <--       liftIO ((,) <$> getDockerImagesLastUsed config-                   <*> getZonedTime)-     let planWriter = buildPlan curTime-                                imagesLastUsed-                                imageRepos-                                danglingImageHashes-                                stoppedContainers-                                runningContainers-                                inspectMap-         plan = toLazyByteString (execWriter planWriter)-     plan' <- case dcAction opts of-                CleanupInteractive ->-                  liftIO (editByteString (intercalate "-" [stackProgName-                                                          ,dockerCmdName-                                                          ,dockerCleanupCmdName-                                                          ,"plan"])-                                         plan)-                CleanupImmediate -> return plan-                CleanupDryRun -> do liftIO (LBS.hPut stdout plan)-                                    return LBS.empty-     mapM_ performPlanLine-           (reverse (filter filterPlanLine (lines (LBS.unpack plan'))))-     allImageHashesOut <- readDockerProcess ["images","-aq","--no-trunc"]-     liftIO (pruneDockerImagesLastUsed config (lines (decodeUtf8 allImageHashesOut)))-  where-    filterPlanLine line =-      case line of-        c:_ | isSpace c -> False-        _ -> True-    performPlanLine line =-      case filter (not . null) (words (takeWhile (/= '#') line)) of-        [] -> return ()-        (c:_):t:v:_ ->-          do args <- if | toUpper c == 'R' && t == imageStr ->-                            do logInfo $-                                 "Removing image: '" <>-                                 fromString v <>-                                 "'"-                               return ["rmi",v]-                        | toUpper c == 'R' && t == containerStr ->-                            do logInfo $-                                 "Removing container: '" <>-                                 fromString v <>-                                 "'"-                               return ["rm","-f",v]-                        | otherwise -> throwM (InvalidCleanupCommandException line)-             e <- try (readDockerProcess args)-             case e of-               Left ex ->-                 logError $-                   "Could not remove: '" <>-                   fromString v <>-                   "': " <>-                   displayShow (ex :: ExitCodeException)-               Right _ -> return ()-        _ -> throwM (InvalidCleanupCommandException line)-    parseImagesOut = Map.fromListWith (++) . map parseImageRepo . drop 1 . lines . decodeUtf8-      where parseImageRepo :: String -> (String, [String])-            parseImageRepo line =-              case words line of-                repo:tag:hash:_-                  | repo == "<none>" -> (hash,[])-                  | tag == "<none>" -> (hash,[repo])-                  | otherwise -> (hash,[repo ++ ":" ++ tag])-                _ -> impureThrow (InvalidImagesOutputException line)-    parseContainersOut = map parseContainer . drop 1 . lines . decodeUtf8-      where parseContainer line =-              case words line of-                hash:image:rest | last:_ <- reverse rest -> (hash,(image,last))-                _ -> impureThrow (InvalidPSOutputException line)-    buildPlan curTime-              imagesLastUsed-              imageRepos-              danglingImageHashes-              stoppedContainers-              runningContainers-              inspectMap =-      do case dcAction opts of-           CleanupInteractive ->-             do buildStrLn-                  (concat-                     ["# STACK DOCKER CLEANUP PLAN"-                     ,"\n#"-                     ,"\n# When you leave the editor, the lines in this plan will be processed."-                     ,"\n#"-                     ,"\n# Lines that begin with 'R' denote an image or container that will be."-                     ,"\n# removed.  You may change the first character to/from 'R' to remove/keep"-                     ,"\n# and image or container that would otherwise be kept/removed."-                     ,"\n#"-                     ,"\n# To cancel the cleanup, delete all lines in this file."-                     ,"\n#"-                     ,"\n# By default, the following images/containers will be removed:"-                     ,"\n#"])-                buildDefault dcRemoveKnownImagesLastUsedDaysAgo "Known images last used"-                buildDefault dcRemoveUnknownImagesCreatedDaysAgo "Unknown images created"-                buildDefault dcRemoveDanglingImagesCreatedDaysAgo "Dangling images created"-                buildDefault dcRemoveStoppedContainersCreatedDaysAgo "Stopped containers created"-                buildDefault dcRemoveRunningContainersCreatedDaysAgo "Running containers created"-                buildStrLn-                  (concat-                     ["#"-                     ,"\n# The default plan can be adjusted using command-line arguments."-                     ,"\n# Run '" ++ unwords [stackProgName, dockerCmdName, dockerCleanupCmdName] ++-                      " --help' for details."-                     ,"\n#"])-           _ -> buildStrLn-                  (unlines-                    ["# Lines that begin with 'R' denote an image or container that will be."-                    ,"# removed."])-         buildSection "KNOWN IMAGES (pulled/used by stack)"-                      imagesLastUsed-                      buildKnownImage-         buildSection "UNKNOWN IMAGES (not managed by stack)"-                      (sortCreated (Map.toList (foldl' (\m (h,_) -> Map.delete h m)-                                                       imageRepos-                                                       imagesLastUsed)))-                      buildUnknownImage-         buildSection "DANGLING IMAGES (no named references and not depended on by other images)"-                      (sortCreated (map (,()) danglingImageHashes))-                      buildDanglingImage-         buildSection "STOPPED CONTAINERS"-                      (sortCreated stoppedContainers)-                      (buildContainer (dcRemoveStoppedContainersCreatedDaysAgo opts))-         buildSection "RUNNING CONTAINERS"-                      (sortCreated runningContainers)-                      (buildContainer (dcRemoveRunningContainersCreatedDaysAgo opts))-      where-        buildDefault accessor description =-          case accessor opts of-            Just days -> buildStrLn ("#   - " ++ description ++ " at least " ++ showDays days ++ ".")-            Nothing -> return ()-        sortCreated =-            sortWith (\(_,_,x) -> Down x) .-             mapMaybe (\(h,r) ->-                case Map.lookup h inspectMap of-                    Nothing -> Nothing-                    Just ii -> Just (h,r,iiCreated ii))-        buildSection sectionHead items itemBuilder =-          do let (anyWrote,b) = runWriter (forM items itemBuilder)-             when (or anyWrote) $-                do buildSectionHead sectionHead-                   tell b-        buildKnownImage (imageHash,lastUsedProjects) =-          case Map.lookup imageHash imageRepos of-            Just repos@(_:_) ->-              do case lastUsedProjects of-                   (l,_):_ -> forM_ repos (buildImageTime (dcRemoveKnownImagesLastUsedDaysAgo opts) l)-                   _ -> forM_ repos buildKeepImage-                 forM_ lastUsedProjects buildProject-                 buildInspect imageHash-                 return True-            _ -> return False-        buildUnknownImage (hash, repos, created) =-          case repos of-            [] -> return False-            _ -> do forM_ repos (buildImageTime (dcRemoveUnknownImagesCreatedDaysAgo opts) created)-                    buildInspect hash-                    return True-        buildDanglingImage (hash, (), created) =-          do buildImageTime (dcRemoveDanglingImagesCreatedDaysAgo opts) created hash-             buildInspect hash-             return True-        buildContainer removeAge (hash,(image,name),created) =-          do let disp = name ++ " (image: " ++ image ++ ")"-             buildTime containerStr removeAge created disp-             buildInspect hash-             return True-        buildProject (lastUsedTime, projectPath) =-          buildInfo ("Last used " ++-                     showDaysAgo lastUsedTime ++-                     " in " ++-                     projectPath)-        buildInspect hash =-          case Map.lookup hash inspectMap of-            Just Inspect{iiCreated,iiVirtualSize} ->-              buildInfo ("Created " ++-                         showDaysAgo iiCreated ++-                         maybe ""-                               (\s -> " (size: " ++-                                      printf "%g" (fromIntegral s / 1024.0 / 1024.0 :: Float) ++-                                      "M)")-                               iiVirtualSize)-            Nothing -> return ()-        showDays days =-          case days of-            0 -> "today"-            1 -> "yesterday"-            n -> show n ++ " days ago"-        showDaysAgo oldTime = showDays (daysAgo oldTime)-        daysAgo oldTime =-          let ZonedTime (LocalTime today _) zone = curTime-              LocalTime oldDay _ = utcToLocalTime zone oldTime-          in diffDays today oldDay-        buildImageTime = buildTime imageStr-        buildTime t removeAge time disp =-          case removeAge of-            Just d | daysAgo time >= d -> buildStrLn ("R " ++ t ++ " " ++ disp)-            _ -> buildKeep t disp-        buildKeep t d = buildStrLn ("  " ++ t ++ " " ++ d)-        buildKeepImage = buildKeep imageStr-        buildSectionHead s = buildStrLn ("\n#\n# " ++ s ++ "\n#\n")-        buildInfo = buildStrLn . ("        # " ++)-        buildStrLn l = do buildStr l-                          tell (charUtf8 '\n')-        buildStr = tell . stringUtf8--    imageStr = "image"-    containerStr = "container"+    mountArg mountSuffix (Mount host container) =+      ["-v",host ++ ":" ++ container ++ mountSuffix]+    sshRelDir = relDirDotSsh  -- | Inspect Docker image or container. inspect :: (HasProcessContext env, HasLogFunc env)@@ -636,10 +335,13 @@  -- | Inspect multiple Docker images and/or containers. inspects :: (HasProcessContext env, HasLogFunc env)-         => [String] -> RIO env (Map String Inspect)+         => [String] -> RIO env (Map Text Inspect) inspects [] = return Map.empty inspects images =-  do maybeInspectOut <- try (readDockerProcess ("inspect" : images))+  do maybeInspectOut <-+       -- not using 'readDockerProcess' as the error from a missing image+       -- needs to be recovered.+       try (BL.toStrict . fst <$> proc "docker" ("inspect" : images) readProcess_)      case maybeInspectOut of        Right inspectOut ->          -- filtering with 'isAscii' to workaround @docker inspect@ output containing invalid UTF-8@@ -657,7 +359,7 @@   do config <- view configL      let docker = configDocker config      checkDockerVersion docker-     pullImage docker (dockerImage docker)+     either throwIO (pullImage docker) (dockerImage docker)  -- | Pull Docker image from registry. pullImage :: (HasProcessContext env, HasLogFunc env)@@ -697,7 +399,7 @@      dockerVersionOut <- readDockerProcess ["--version"]      case words (decodeUtf8 dockerVersionOut) of        (_:_:v:_) ->-         case parseVersionFromString (stripVersion v) of+         case parseVersion (stripVersion v) of            Just v'              | v' < minimumDockerVersion ->                throwIO (DockerTooOldException minimumDockerVersion v')@@ -709,20 +411,19 @@                return ()            _ -> throwIO InvalidVersionOutputException        _ -> throwIO InvalidVersionOutputException-  where minimumDockerVersion = $(mkVersion "1.6.0")+  where minimumDockerVersion = mkVersion [1, 6, 0]         prohibitedDockerVersions = []         stripVersion v = takeWhile (/= '-') (dropWhileEnd (not . isDigit) v)  -- | Remove the project's Docker sandbox.-reset :: (MonadIO m, MonadReader env m, HasConfig env)-  => Maybe (Path Abs Dir) -> Bool -> m ()-reset maybeProjectRoot keepHome = do+reset :: HasConfig env => Bool -> RIO env ()+reset keepHome = do+  projectRoot <- getProjectRoot   dockerSandboxDir <- projectDockerSandboxDir projectRoot   liftIO (removeDirectoryContents             dockerSandboxDir             [homeDirName | keepHome]             [])-  where projectRoot = fromMaybeProjectRoot maybeProjectRoot  -- | The Docker container "entrypoint": special actions performed when first entering -- a container, such as switching the UID/GID to the "outside-Docker" user's.@@ -748,7 +449,7 @@           -- If the 'stack' user exists in the image, copy any build plans and package indices from           -- its original home directory to the host's stack root, to avoid needing to download them           origStackHomeDir <- liftIO $ parseAbsDir (User.homeDirectory ue)-          let origStackRoot = origStackHomeDir </> $(mkRelDir ("." ++ stackProgName))+          let origStackRoot = origStackHomeDir </> relDirDotStackProgName           buildPlanDirExists <- doesDirExist (buildPlanDir origStackRoot)           when buildPlanDirExists $ do             (_, buildPlans) <- listDir (buildPlanDir origStackRoot)@@ -758,25 +459,8 @@               unless exists $ do                 ensureDir (parent destBuildPlan)                 copyFile srcBuildPlan destBuildPlan-          forM_ clIndices $ \pkgIdx -> do-            msrcIndex <- runRIO (set stackRootL origStackRoot config) $ do-               srcIndex <- configPackageIndex (indexName pkgIdx)-               exists <- doesFileExist srcIndex-               return $ if exists-                 then Just srcIndex-                 else Nothing-            case msrcIndex of-              Nothing -> return ()-              Just srcIndex ->-                runRIO config $ do-                  destIndex <- configPackageIndex (indexName pkgIdx)-                  exists <- doesFileExist destIndex-                  unless exists $ do-                    ensureDir (parent destIndex)-                    copyFile srcIndex destIndex     return True   where-    CabalLoader {..} = configCabalLoader     updateOrCreateStackUser estackUserEntry homeDir DockerUser{..} = do       case estackUserEntry of         Left _ -> do@@ -843,17 +527,24 @@  -- | Produce a strict 'S.ByteString' from the stdout of a -- process. Throws a 'ReadProcessException' exception if the--- process fails.  Logs process's stderr using @logError@.+-- process fails.+--+-- The stderr output is passed straight through, which is desirable for some cases+-- e.g. docker pull, in which docker uses stderr for progress output.+--+-- Use 'readProcess_' directly to customize this. readDockerProcess     :: (HasProcessContext env, HasLogFunc env)     => [String] -> RIO env BS.ByteString-readDockerProcess args = BL.toStrict <$> proc "docker" args readProcessStdout_ -- FIXME stderr isn't logged with logError, should it be?+readDockerProcess args = BL.toStrict <$> proc "docker" args readProcessStdout_  -- | Name of home directory within docker sandbox. homeDirName :: Path Rel Dir-homeDirName = $(mkRelDir "_home/")+homeDirName = relDirUnderHome  -- | Directory where 'stack' executable is bind-mounted in Docker container+-- This refers to a path in the Linux *container*, and so should remain a+-- 'FilePath' (not 'Path Abs Dir') so that it works when the host runs Windows. hostBinDir :: FilePath hostBinDir = "/opt/host/bin" @@ -862,35 +553,21 @@ decodeUtf8 bs = T.unpack (T.decodeUtf8 bs)  -- | Fail with friendly error if project root not set.-fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir-fromMaybeProjectRoot = fromMaybe (impureThrow CannotDetermineProjectRootException)+getProjectRoot :: HasConfig env => RIO env (Path Abs Dir)+getProjectRoot = do+  mroot <- view $ configL.to configProjectRoot+  maybe (throwIO CannotDetermineProjectRootException) pure mroot  -- | Environment variable that contained the old sandbox ID. -- | Use of this variable is deprecated, and only used to detect old images. oldSandboxIdEnvVar :: String oldSandboxIdEnvVar = "DOCKER_SANDBOX_ID" --- | Options for 'cleanup'.-data CleanupOpts = CleanupOpts-  { dcAction                                :: !CleanupAction-  , dcRemoveKnownImagesLastUsedDaysAgo      :: !(Maybe Integer)-  , dcRemoveUnknownImagesCreatedDaysAgo     :: !(Maybe Integer)-  , dcRemoveDanglingImagesCreatedDaysAgo    :: !(Maybe Integer)-  , dcRemoveStoppedContainersCreatedDaysAgo :: !(Maybe Integer)-  , dcRemoveRunningContainersCreatedDaysAgo :: !(Maybe Integer) }-  deriving (Show)---- | Cleanup action.-data CleanupAction = CleanupInteractive-                   | CleanupImmediate-                   | CleanupDryRun-  deriving (Show)- -- | Parsed result of @docker inspect@. data Inspect = Inspect   {iiConfig      :: ImageConfig   ,iiCreated     :: UTCTime-  ,iiId          :: String+  ,iiId          :: Text   ,iiVirtualSize :: Maybe Integer}   deriving (Show) @@ -916,10 +593,3 @@        ImageConfig          <$> fmap join (o .:? "Env") .!= []          <*> fmap join (o .:? "Entrypoint") .!= []---- | Function to get command and arguments to run in Docker container-type GetCmdArgs env-   = DockerOpts-  -> Inspect-  -> Bool-  -> RIO env (FilePath,[String],[(String,String)],[Mount])
− src/Stack/Docker/GlobalDB.hs 
@@ -1,122 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings,-             GADTs, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving,-             RankNTypes, NamedFieldPuns #-}---- | Global sqlite database shared by all projects.--- Warning: this is currently only accessible from __outside__ a Docker container.-module Stack.Docker.GlobalDB-  (updateDockerImageLastUsed-  ,getDockerImagesLastUsed-  ,pruneDockerImagesLastUsed-  ,DockerImageLastUsed-  ,DockerImageProjectId-  ,getDockerImageExe-  ,setDockerImageExe-  ,DockerImageExeId)-  where--import           Control.Monad.Logger (NoLoggingT) -- TODO remove dep when persistent drops monad-logger-import           Control.Monad.Trans.Resource (ResourceT)-import           Stack.Prelude-import           Data.List (sortBy, isInfixOf, stripPrefix)-import           Data.List.Extra (stripSuffix)-import qualified Data.Map.Strict as Map-import qualified Data.Text as T-import           Data.Time.Clock (UTCTime,getCurrentTime)-import           Database.Persist-import           Database.Persist.Sqlite-import           Database.Persist.TH-import           Path (parent, (<.>))-import           Path.IO (ensureDir)-import           Stack.Types.Config-import           Stack.Types.Docker-import           System.FileLock (withFileLock, SharedExclusive(Exclusive))--share [mkPersist sqlSettings, mkMigrate "migrateTables"] [persistLowerCase|-DockerImageProject-    imageHash                 String-    projectPath               FilePath-    lastUsedTime              UTCTime-    DockerImageProjectPathKey imageHash projectPath-    deriving Show-DockerImageExe-    imageHash                 String-    exePath                   FilePath-    exeTimestamp              UTCTime-    compatible                Bool-    DockerImageExeUnique      imageHash exePath exeTimestamp-    deriving Show-|]---- | Update last used time and project for a Docker image hash.-updateDockerImageLastUsed :: Config -> String -> FilePath -> IO ()-updateDockerImageLastUsed config imageId projectPath =-  do curTime <- getCurrentTime-     _ <- withGlobalDB config (upsert (DockerImageProject imageId projectPath curTime) [])-     return ()---- | Get a list of Docker image hashes and when they were last used.-getDockerImagesLastUsed :: Config -> IO [DockerImageLastUsed]-getDockerImagesLastUsed config =-      sortBy (flip sortImage)-    . Map.toDescList-    . Map.fromListWith (++)-    . map mapImageProject-  <$> withGlobalDB-        config-        (selectList [] [Asc DockerImageProjectLastUsedTime])-  where-    mapImageProject (Entity _ imageProject) =-      (dockerImageProjectImageHash imageProject-      ,[(dockerImageProjectLastUsedTime imageProject-        ,dockerImageProjectProjectPath imageProject)])-    sortImage (_,(a,_):_) (_,(b,_):_) = compare a b-    sortImage _ _ = EQ---- | Given a list of all existing Docker images, remove any that no longer exist from--- the database.-pruneDockerImagesLastUsed :: Config -> [String] -> IO ()-pruneDockerImagesLastUsed config existingHashes =-  withGlobalDB config go-  where-    go = do-        l <- selectList [] []-        forM_ l (\(Entity k DockerImageProject{dockerImageProjectImageHash = h}) ->-            when (h `notElem` existingHashes) $ delete k)---- | Get the record of whether an executable is compatible with a Docker image-getDockerImageExe :: Config -> String -> FilePath -> UTCTime -> IO (Maybe Bool)-getDockerImageExe config imageId exePath exeTimestamp =-    withGlobalDB config $-      fmap (dockerImageExeCompatible . entityVal) <$>-      getBy (DockerImageExeUnique imageId exePath exeTimestamp)---- | Seet the record of whether an executable is compatible with a Docker image-setDockerImageExe :: Config -> String -> FilePath -> UTCTime -> Bool -> IO ()-setDockerImageExe config imageId exePath exeTimestamp compatible =-    withGlobalDB config $-    do _ <- upsert (DockerImageExe imageId exePath exeTimestamp compatible) []-       return ()---- | Run an action with the global database.  This performs any needed migrations as well.-withGlobalDB :: forall a. Config -> SqlPersistT (NoLoggingT (ResourceT IO)) a -> IO a-withGlobalDB config action =-  do let db = dockerDatabasePath (configDocker config)-     dbLock <- db <.> "lock"-     ensureDir (parent db)-     withFileLock (toFilePath dbLock) Exclusive (\_fl -> runSqlite (T.pack (toFilePath db))-               (do _ <- runMigrationSilent migrateTables-                   action))-         `catch` \ex -> do-             let str = show ex-                 str' = fromMaybe str $ stripPrefix "user error (" $-                        fromMaybe str $ stripSuffix ")" str-             if "ErrorReadOnly" `isInfixOf` str-                 then throwString $ str' ++-                     " This likely indicates that your DB file, " ++-                     toFilePath db ++ ", has incorrect permissions or ownership."-                 else throwIO (ex :: IOException)---- | Date and project path where Docker image hash last used.-type DockerImageLastUsed = (String, [(UTCTime, FilePath)])
src/Stack/Dot.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}  module Stack.Dot (dot                  ,listDependencies@@ -16,33 +15,35 @@                  ) where  import qualified Data.Foldable as F-import qualified Data.HashSet as HashSet-import qualified Data.Map as Map+import qualified Data.Sequence as Seq import qualified Data.Set as Set+import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified Data.Traversable as T import           Distribution.Text (display)+import qualified Distribution.PackageDescription as PD import qualified Distribution.SPDX.License as SPDX import           Distribution.License (License(BSD3), licenseFromSPDX)+import           Distribution.Types.PackageName (mkPackageName)+import           RIO.PrettyPrint (HasTerm (..), HasStylesUpdate (..))+import           RIO.Process (HasProcessContext (..)) import           Stack.Build (loadPackage)-import           Stack.Build.Installed (getInstalled, GetInstalledOpts(..))+import           Stack.Build.Installed (getInstalled, toInstallMap) import           Stack.Build.Source-import           Stack.Build.Target-import           Stack.Config (getLocalPackages) import           Stack.Constants import           Stack.Package import           Stack.PackageDump (DumpPackage(..))-import           Stack.Prelude hiding (Display (..))+import           Stack.Prelude hiding (Display (..), pkgName, loadPackage)+import qualified Stack.Prelude (pkgName)+import           Stack.Runners+import           Stack.SourceMap import           Stack.Types.Build-import           Stack.Types.BuildPlan+import           Stack.Types.Compiler (wantedToActual) 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.SourceMap+import           Stack.Build.Target(NeedTargets(..), parseTargets)  -- | Options record for @stack dot@ data DotOpts = DotOpts@@ -52,16 +53,18 @@     -- ^ Include dependencies on base     , dotDependencyDepth :: !(Maybe Int)     -- ^ Limit the depth of dependency resolution to (Just n) or continue until fixpoint-    , dotPrune :: !(Set String)+    , dotPrune :: !(Set PackageName)     -- ^ Package names to prune from the graph     , dotTargets :: [Text]     -- ^ stack TARGETs to trace dependencies for-    , dotFlags :: !(Map (Maybe PackageName) (Map FlagName Bool))+    , dotFlags :: !(Map ApplyCLIFlag (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'.+    , dotGlobalHints :: Bool+    -- ^ Use global hints instead of relying on an actual GHC installation.     }  data ListDepsOpts = ListDepsOpts@@ -71,10 +74,12 @@     -- ^ Separator between the package name and details.     , listDepsLicense :: !Bool     -- ^ Print dependency licenses instead of versions.+    , listDepsTree :: !Bool+    -- ^ Print dependency tree.     }  -- | Visualize the project's dependencies as a graphviz graph-dot :: HasEnvConfig env => DotOpts -> RIO env ()+dot :: DotOpts -> RIO Runner () dot dotOpts = do   (localNames, prunedGraph) <- createPrunedDependencyGraph dotOpts   printGraph dotOpts localNames prunedGraph@@ -90,77 +95,134 @@ -- | 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 :: HasEnvConfig env-                            => DotOpts-                            -> RIO env+createPrunedDependencyGraph :: DotOpts+                            -> RIO Runner                                  (Set PackageName,                                   Map PackageName (Set PackageName, DotPayload))-createPrunedDependencyGraph dotOpts = do-  localNames <- liftM (Map.keysSet . lpProject) getLocalPackages+createPrunedDependencyGraph dotOpts = withDotConfig dotOpts $ do+  localNames <- view $ buildConfigL.to (Map.keysSet . smwProject . bcSMWanted)+  logDebug "Creating dependency graph"   resultGraph <- createDependencyGraph dotOpts   let pkgsToPrune = if dotIncludeBase dotOpts                        then dotPrune dotOpts                        else Set.insert "base" (dotPrune dotOpts)       prunedGraph = pruneGraph localNames pkgsToPrune resultGraph+  logDebug "Returning prouned dependency graph"   return (localNames, prunedGraph)  -- | Create the dependency graph, the result is a map from a package -- name to a tuple of dependencies and payload if available. This -- function mainly gathers the required arguments for -- @resolveDependencies@.-createDependencyGraph :: HasEnvConfig env-                       => DotOpts-                       -> RIO env (Map PackageName (Set PackageName, DotPayload))+createDependencyGraph+  :: DotOpts+  -> RIO DotConfig (Map PackageName (Set PackageName, DotPayload)) createDependencyGraph dotOpts = do-  (locals, sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI-      { boptsCLITargets = dotTargets dotOpts-      , boptsCLIFlags = dotFlags dotOpts-      }-  let graph = Map.fromList (localDependencies dotOpts (filter lpWanted locals))-  (installedMap, globalDump, _, _) <- getInstalled (GetInstalledOpts False False False)-                                                   sourceMap+  sourceMap <- view sourceMapL+  locals <- for (toList $ smProject sourceMap) loadLocalPackage+  let graph = Map.fromList $ projectPackageDependencies dotOpts (filter lpWanted locals)+  globalDump <- view $ to dcGlobalDump   -- TODO: Can there be multiple entries for wired-in-packages? If so,   -- this will choose one arbitrarily..-  let globalDumpMap = Map.fromList $ map (\dp -> (packageIdentifierName (dpPackageIdent dp), dp)) globalDump+  let globalDumpMap = Map.fromList $ map (\dp -> (Stack.Prelude.pkgName (dpPackageIdent dp), dp)) globalDump       globalIdMap = Map.fromList $ map (\dp -> (dpGhcPkgId dp, dpPackageIdent dp)) globalDump-  let depLoader = createDepLoader sourceMap installedMap globalDumpMap globalIdMap loadPackageDeps-      loadPackageDeps name version loc flags ghcOptions+  let depLoader = createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps+      loadPackageDeps name version loc flags ghcOptions cabalConfigOpts           -- Skip packages that can't be loaded - see           -- https://github.com/commercialhaskell/stack/issues/2967-          | name `elem` [$(mkPackageName "rts"), $(mkPackageName "ghc")] =+          | name `elem` [mkPackageName "rts", mkPackageName "ghc"] =               return (Set.empty, DotPayload (Just version) (Just $ Right BSD3))-          | otherwise = fmap (packageAllDeps &&& makePayload) (loadPackage loc flags ghcOptions)+          | otherwise = fmap (packageAllDeps &&& makePayload) (loadPackage loc flags ghcOptions cabalConfigOpts)   resolveDependencies (dotDependencyDepth dotOpts) graph depLoader   where makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) -listDependencies :: HasEnvConfig env-                  => ListDepsOpts-                  -> RIO env ()+listDependencies+  :: ListDepsOpts+  -> RIO Runner () listDependencies opts = do   let dotOpts = listDepsDotOpts opts-  (_, resultGraph) <- createPrunedDependencyGraph dotOpts-  void (Map.traverseWithKey go (snd <$> resultGraph))-    where go name payload =-            let payloadText =-                  if listDepsLicense opts-                      then maybe "<unknown>" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload)-                      else maybe "<unknown>" (Text.pack . show) (payloadVersion payload)-                line = packageNameText name <> listDepsSep opts <> payloadText-            in  liftIO $ Text.putStrLn line+  (pkgs, resultGraph) <- createPrunedDependencyGraph dotOpts+  if listDepsTree opts then+    do+      liftIO $ Text.putStrLn "Packages"+      liftIO $ printTree opts 0 [] (treeRoots opts pkgs) resultGraph+    else+      void (Map.traverseWithKey go (snd <$> resultGraph))+      where go name payload = liftIO $ Text.putStrLn $ listDepsLine opts name payload +treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName+treeRoots opts projectPackages' =+  let targets = dotTargets $ listDepsDotOpts opts+   in if null targets+        then projectPackages'+        else Set.fromList $ map (mkPackageName . Text.unpack) targets++printTree :: ListDepsOpts+          -> Int+          -> [Int]+          -> Set PackageName+          -> Map PackageName (Set PackageName, DotPayload)+          -> IO ()+printTree opts depth remainingDepsCounts packages dependencyMap =+  F.sequence_ $ Seq.mapWithIndex go (toSeq packages)+  where+    toSeq = Seq.fromList . Set.toList+    go index name = let newDepsCounts = remainingDepsCounts ++ [Set.size packages - index - 1]+                     in+                      case Map.lookup name dependencyMap of+                        Just (deps, payload) -> do+                          printTreeNode opts depth newDepsCounts deps payload name+                          if Just depth == dotDependencyDepth (listDepsDotOpts opts)+                             then return ()+                             else printTree opts (depth + 1) newDepsCounts deps dependencyMap+                        -- TODO: Define this behaviour, maybe return an error?+                        Nothing -> return ()++printTreeNode :: ListDepsOpts+              -> Int+              -> [Int]+              -> Set PackageName+              -> DotPayload+              -> PackageName+              -> IO ()+printTreeNode opts depth remainingDepsCounts deps payload name =+  let remainingDepth = fromMaybe 999 (dotDependencyDepth (listDepsDotOpts opts)) - depth+      hasDeps = not $ null deps+   in Text.putStrLn $ treeNodePrefix "" remainingDepsCounts hasDeps  remainingDepth  <> " " <> listDepsLine opts name payload++treeNodePrefix :: Text -> [Int] -> Bool -> Int -> Text+treeNodePrefix t [] _ _      = t+treeNodePrefix t [0] True  0 = t <> "└──"+treeNodePrefix t [_] True  0 = t <> "├──"+treeNodePrefix t [0] True  _ = t <> "└─┬"+treeNodePrefix t [_] True  _ = t <> "├─┬"+treeNodePrefix t [0] False _ = t <> "└──"+treeNodePrefix t [_] False _ = t <> "├──"+treeNodePrefix t (0:ns) d remainingDepth = treeNodePrefix (t <> "  ") ns d remainingDepth+treeNodePrefix t (_:ns) d remainingDepth = treeNodePrefix (t <> "│ ") ns d remainingDepth++listDepsLine :: ListDepsOpts -> PackageName -> DotPayload -> Text+listDepsLine opts name payload = Text.pack (packageNameString name) <> listDepsSep opts <> payloadText opts payload++payloadText :: ListDepsOpts -> DotPayload -> Text+payloadText opts payload =+  if listDepsLicense opts+    then maybe "<unknown>" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload)+    else maybe "<unknown>" (Text.pack . display) (payloadVersion payload)+ -- | @pruneGraph dontPrune toPrune graph@ prunes all packages in -- @graph@ with a name in @toPrune@ and removes resulting orphans -- unless they are in @dontPrune@ pruneGraph :: (F.Foldable f, F.Foldable g, Eq a)            => f PackageName-           -> g String+           -> g PackageName            -> Map PackageName (Set PackageName, a)            -> Map PackageName (Set PackageName, a) pruneGraph dontPrune names =   pruneUnreachable dontPrune . Map.mapMaybeWithKey (\pkg (pkgDeps,x) ->-    if show pkg `F.elem` names+    if pkg `F.elem` names       then Nothing-      else let filtered = Set.filter (\n -> show n `F.notElem` names) pkgDeps+      else let filtered = Set.filter (\n -> n `F.notElem` names) pkgDeps            in if Set.null filtered && not (Set.null pkgDeps)                 then Nothing                 else Just (filtered,x))@@ -199,46 +261,64 @@   where unifier (pkgs1,v1) (pkgs2,_) = (Set.union pkgs1 pkgs2, v1)  -- | Given a SourceMap and a dependency loader, load the set of dependencies for a package-createDepLoader :: Applicative m-                => Map PackageName PackageSource-                -> Map PackageName (InstallLocation, Installed)-                -> Map PackageName (DumpPackage () () ())+createDepLoader :: SourceMap+                -> Map PackageName DumpPackage                 -> Map GhcPkgId PackageIdentifier-                -> (PackageName -> Version -> PackageLocationIndex FilePath ->-                    Map FlagName Bool -> [Text] -> m (Set PackageName, DotPayload))+                -> (PackageName -> Version -> PackageLocationImmutable ->+                    Map FlagName Bool -> [Text] -> [Text] -> RIO DotConfig (Set PackageName, DotPayload))                 -> PackageName-                -> m (Set PackageName, DotPayload)-createDepLoader sourceMap installed globalDumpMap globalIdMap loadPackageDeps pkgName =-  if not (pkgName `HashSet.member` wiredInPackages)-      then case Map.lookup pkgName sourceMap of-          Just (PSFiles lp _) -> pure (packageAllDeps pkg, payloadFromLocal pkg)-            where-              pkg = localPackageToPackage lp-          Just (PSIndex _ flags ghcOptions loc) ->-              -- FIXME pretty certain this could be cleaned up a lot by including more info in PackageSource-              let PackageIdentifierRevision (PackageIdentifier name version) _ = loc-               in assert (pkgName == name) (loadPackageDeps pkgName version (PLIndex loc) flags ghcOptions)-          Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed))-      -- For wired-in-packages, use information from ghc-pkg (see #3084)-      else case Map.lookup pkgName globalDumpMap of-          Nothing -> error ("Invariant violated: Expected to find wired-in-package " ++ packageNameString pkgName ++ " in global DB")-          Just dp -> pure (Set.fromList deps, payloadFromDump dp)-            where-              deps = map (\depId -> maybe (error ("Invariant violated: Expected to find " ++ ghcPkgIdString depId ++ " in global DB"))-                                          packageIdentifierName-                                          (Map.lookup depId globalIdMap))-                         (dpDepends dp)+                -> RIO DotConfig (Set PackageName, DotPayload)+createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName = do+  fromMaybe noDepsErr+    (projectPackageDeps <|> dependencyDeps <|> globalDeps)   where+    projectPackageDeps =+      loadDeps <$> Map.lookup pkgName (smProject sourceMap)+      where+        loadDeps pp = do+          pkg <- loadCommonPackage (ppCommon pp)+          pure (packageAllDeps pkg, payloadFromLocal pkg)++    dependencyDeps =+      loadDeps <$> Map.lookup pkgName (smDeps sourceMap)+      where+        loadDeps DepPackage{dpLocation=PLMutable dir} = do+              pp <- mkProjectPackage YesPrintWarnings dir False+              pkg <- loadCommonPackage (ppCommon pp)+              pure (packageAllDeps pkg, payloadFromLocal pkg)++        loadDeps dp@DepPackage{dpLocation=PLImmutable loc} = do+          let common = dpCommon dp+          gpd <- liftIO $ cpGPD common+          let PackageIdentifier name version = PD.package $ PD.packageDescription gpd+              flags = cpFlags common+              ghcOptions = cpGhcOptions common+              cabalConfigOpts = cpCabalConfigOpts common+          assert (pkgName == name) (loadPackageDeps pkgName version loc flags ghcOptions cabalConfigOpts)++    -- If package is a global package, use info from ghc-pkg (#4324, #3084)+    globalDeps =+      pure . getDepsFromDump <$> Map.lookup pkgName globalDumpMap+      where+        getDepsFromDump dump =+          (Set.fromList deps, payloadFromDump dump)+          where+            deps = map ghcIdToPackageName (dpDepends dump)+            ghcIdToPackageName depId =+              let errText = "Invariant violated: Expected to find "+              in maybe (error (errText ++ ghcPkgIdString depId ++ " in global DB"))+                 Stack.Prelude.pkgName+                 (Map.lookup depId globalIdMap)++    noDepsErr = error ("Invariant violated: The '" ++ packageNameString pkgName+                ++ "' package was not found in any of the dependency sources")+     payloadFromLocal pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg)-    payloadFromInstalled maybePkg = DotPayload (fmap (installedVersion . snd) maybePkg) $-        case maybePkg of-            Just (_, Library _ _ mlicense) -> mlicense-            _ -> Nothing-    payloadFromDump dp = DotPayload (Just $ packageIdentifierVersion $ dpPackageIdent dp) (Right <$> dpLicense dp)+    payloadFromDump dp = DotPayload (Just $ pkgVersion $ dpPackageIdent dp) (Right <$> dpLicense dp) --- | Resolve the direct (depth 0) external dependencies of the given local packages-localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]-localDependencies dotOpts locals =+-- | Resolve the direct (depth 0) external dependencies of the given local packages (assumed to come from project packages)+projectPackageDependencies :: DotOpts -> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]+projectPackageDependencies dotOpts locals =     map (\lp -> let pkg = localPackageToPackage lp                  in (packageName pkg, (deps pkg, lpPayload pkg)))         locals@@ -262,7 +342,7 @@   void (Map.traverseWithKey printEdges (fst <$> graph))   liftIO $ Text.putStrLn "}"   where filteredLocals = Set.filter (\local' ->-          packageNameString local' `Set.notMember` dotPrune dotOpts) locals+          local' `Set.notMember` dotPrune dotOpts) locals  -- | Print the local nodes with a different style depending on options printLocalNodes :: (F.Foldable t, MonadIO m)@@ -293,7 +373,7 @@  -- | Convert a package name to a graph node name. nodeName :: PackageName -> Text-nodeName name = "\"" <> packageNameText name <> "\""+nodeName name = "\"" <> Text.pack (packageNameString name) <> "\""  -- | Print a node with no dependencies printLeaf :: MonadIO m => PackageName -> m ()@@ -304,8 +384,104 @@  -- | Check if the package is wired in (shipped with) ghc isWiredIn :: PackageName -> Bool-isWiredIn = (`HashSet.member` wiredInPackages)+isWiredIn = (`Set.member` wiredInPackages)  localPackageToPackage :: LocalPackage -> Package localPackageToPackage lp =   fromMaybe (lpPackage lp) (lpTestBench lp)++-- Plumbing for --test and --bench flags+withDotConfig+    :: DotOpts+    -> RIO DotConfig a+    -> RIO Runner a+withDotConfig opts inner =+  local (over globalOptsL modifyGO) $+    if dotGlobalHints opts+      then withConfig NoReexec $ withBuildConfig withGlobalHints+      else withConfig YesReexec withReal+  where+    withGlobalHints = do+      bconfig <- view buildConfigL+      globals <- globalsFromHints $ smwCompiler $ bcSMWanted bconfig+      fakeGhcPkgId <- parseGhcPkgId "ignored"+      let smActual = SMActual+            { smaCompiler = wantedToActual $ smwCompiler $ bcSMWanted bconfig+            , smaProject = smwProject $ bcSMWanted bconfig+            , smaDeps = smwDeps $ bcSMWanted bconfig+            , smaGlobal = Map.mapWithKey toDump globals+            }+          toDump :: PackageName -> Version -> DumpPackage+          toDump name version = DumpPackage+            { dpGhcPkgId = fakeGhcPkgId+            , dpPackageIdent = PackageIdentifier name version+            , dpParentLibIdent = Nothing+            , dpLicense = Nothing+            , dpLibDirs = []+            , dpLibraries = []+            , dpHasExposedModules = True+            , dpExposedModules = mempty+            , dpDepends = []+            , dpHaddockInterfaces = []+            , dpHaddockHtml = Nothing+            , dpIsExposed = True+            }+          actualPkgs = Map.keysSet (smaDeps smActual) <>+                       Map.keysSet (smaProject smActual)+          prunedActual = smActual { smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs }+      targets <- parseTargets NeedTargets False boptsCLI prunedActual+      logDebug "Loading source map"+      sourceMap <- loadSourceMap targets boptsCLI smActual+      let dc = DotConfig+                  { dcBuildConfig = bconfig+                  , dcSourceMap = sourceMap+                  , dcGlobalDump = toList $ smaGlobal smActual+                  }+      logDebug "DotConfig fully loaded"+      runRIO dc inner++    withReal = withEnvConfig NeedTargets boptsCLI $ do+      envConfig <- ask+      let sourceMap = envConfigSourceMap envConfig+      installMap <- toInstallMap sourceMap+      (_, globalDump, _, _) <- getInstalled installMap+      let dc = DotConfig+            { dcBuildConfig = envConfigBuildConfig envConfig+            , dcSourceMap = sourceMap+            , dcGlobalDump = globalDump+            }+      runRIO dc inner++    boptsCLI = defaultBuildOptsCLI+        { boptsCLITargets = dotTargets opts+        , boptsCLIFlags = dotFlags opts+        }+    modifyGO =+        (if dotTestTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) else id) .+        (if dotBenchTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) else id)++data DotConfig = DotConfig+  { dcBuildConfig :: !BuildConfig+  , dcSourceMap :: !SourceMap+  , dcGlobalDump :: ![DumpPackage]+  }+instance HasLogFunc DotConfig where+  logFuncL = runnerL.logFuncL+instance HasPantryConfig DotConfig where+  pantryConfigL = configL.pantryConfigL+instance HasTerm DotConfig where+  useColorL = runnerL.useColorL+  termWidthL = runnerL.termWidthL+instance HasStylesUpdate DotConfig where+  stylesUpdateL = runnerL.stylesUpdateL+instance HasGHCVariant DotConfig+instance HasPlatform DotConfig+instance HasRunner DotConfig where+  runnerL = configL.runnerL+instance HasProcessContext DotConfig where+  processContextL = runnerL.processContextL+instance HasConfig DotConfig+instance HasBuildConfig DotConfig where+  buildConfigL = lens dcBuildConfig (\x y -> x { dcBuildConfig = y })+instance HasSourceMap DotConfig where+  sourceMapL = lens dcSourceMap (\x y -> x { dcSourceMap = y })
− src/Stack/Fetch.hs 
@@ -1,661 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PatternGuards         #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE PackageImports        #-}-{-# LANGUAGE ViewPatterns          #-}-{-# LANGUAGE RecordWildCards       #-}---- | Functionality for downloading packages securely for cabal's usage.--module Stack.Fetch-    ( unpackPackages-    , unpackPackageIdent-    , unpackPackageIdents-    , fetchPackages-    , untar-    , resolvePackages-    , resolvePackagesAllowMissing-    , ResolvedPackage (..)-    , withCabalFiles-    , loadFromIndex-    ) 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              Stack.Prelude-import              Crypto.Hash (SHA256 (..))-import qualified    Data.ByteString as S-import qualified    Data.Foldable as F-import qualified    Data.HashMap.Strict as HashMap-import qualified    Data.HashSet as HashSet-import              Data.List (intercalate, maximum)-import              Data.List.NonEmpty (NonEmpty)-import qualified    Data.List.NonEmpty as NE-import qualified    Data.Map as Map-import qualified    Data.Set as Set-import qualified    Data.Text as T-import              Data.Text.Encoding (decodeUtf8)-import              Data.Text.Metrics-import              Lens.Micro (to)-import              Network.HTTP.Download-import              Path-import              Path.Extra (toFilePathNoTrailingSep)-import              Path.IO-import              Stack.PackageIndex-import              Stack.Types.BuildPlan-import              Stack.Types.PackageIdentifier-import              Stack.Types.PackageIndex-import              Stack.Types.PackageName-import              Stack.Types.Version-import qualified    System.FilePath as FP-import              System.IO (SeekMode (AbsoluteSeek))-import              System.PosixCompat (setFileMode)--data FetchException-    = Couldn'tReadIndexTarball FilePath Tar.FormatError-    | Couldn'tReadPackageTarball FilePath SomeException-    | UnpackDirectoryAlreadyExists (Set FilePath)-    | CouldNotParsePackageSelectors [String]-    | UnknownPackageNames (Set PackageName)-    | UnknownPackageIdentifiers (HashSet PackageIdentifierRevision) String-        Bool -- Do we use any 00-index.tar.gz indices? Just used for more informative error messages-    deriving Typeable-instance Exception FetchException--instance Show FetchException where-    show (Couldn'tReadIndexTarball fp err) = concat-        [ "There was an error reading the index tarball "-        , fp-        , ": "-        , show err-        ]-    show (Couldn'tReadPackageTarball fp err) = concat-        [ "There was an error reading the package tarball "-        , fp-        , ": "-        , show err-        ]-    show (UnpackDirectoryAlreadyExists dirs) = unlines-        $ "Unable to unpack due to already present directories:"-        : map ("    " ++) (Set.toList dirs)-    show (CouldNotParsePackageSelectors strs) =-        "The following package selectors are not valid package names or identifiers: " ++-        intercalate ", " strs-    show (UnknownPackageNames names) =-        "The following packages were not found in your indices: " ++-        intercalate ", " (map packageNameString $ Set.toList names)-    show (UnknownPackageIdentifiers idents suggestions uses00Index) =-        "The following package identifiers were not found in your indices: " ++-        intercalate ", " (map packageIdentifierRevisionString $ HashSet.toList idents) ++-        (if null suggestions then "" else "\n" ++ suggestions) ++-        (if uses00Index then "\n\nYou seem to be using a legacy 00-index.tar.gz tarball.\nConsider changing your configuration to use a 01-index.tar.gz file.\nAlternatively, you can set the ignore-revision-mismatch setting to true.\nFor more information, see: https://github.com/commercialhaskell/stack/issues/3520" else "")---- | Fetch packages into the cache without unpacking-fetchPackages :: HasCabalLoader env => Set PackageIdentifier -> RIO env ()-fetchPackages idents' = do-    resolved <- resolvePackages Nothing idents Set.empty-    ToFetchResult toFetch alreadyUnpacked <- getToFetch Nothing resolved-    assert (Map.null alreadyUnpacked) (return ())-    nowUnpacked <- fetchPackages' Nothing toFetch-    assert (Map.null nowUnpacked) (return ())-  where-    -- Since we're just fetching tarballs and not unpacking cabal files, we can-    -- always provide a CFILatest cabal file info-    idents = map (flip PackageIdentifierRevision CFILatest) $ Set.toList idents'---- | Intended to work for the command line command.-unpackPackages :: HasCabalLoader env-               => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan-               -> FilePath -- ^ destination-               -> [String] -- ^ names or identifiers-               -> RIO env ()-unpackPackages mSnapshotDef dest input = do-    dest' <- resolveDir' dest-    (names, idents) <- case partitionEithers $ map parse input of-        ([], x) -> return $ partitionEithers x-        (errs, _) -> throwM $ CouldNotParsePackageSelectors errs-    resolved <- resolvePackages mSnapshotDef idents (Set.fromList names)-    ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved-    unless (Map.null alreadyUnpacked) $-        throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked-    unpacked <- fetchPackages' Nothing toFetch-    F.forM_ (Map.toList unpacked) $ \(ident, dest'') -> logInfo $-        "Unpacked " <>-        fromString (packageIdentifierString ident) <>-        " to " <>-        fromString (toFilePath dest'')-  where-    -- Possible future enhancement: parse names as name + version range-    parse s =-        case parsePackageName t of-            Right x -> Right $ Left x-            Left _ ->-                case parsePackageIdentifierRevision t of-                    Right x -> Right $ Right x-                    Left _ -> Left s-      where-        t = T.pack s---- | Same as 'unpackPackageIdents', but for a single package.-unpackPackageIdent-    :: HasCabalLoader env-    => Path Abs Dir -- ^ unpack directory-    -> Path Rel Dir -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157-    -> PackageIdentifierRevision-    -> RIO env (Path Abs Dir)-unpackPackageIdent unpackDir distDir (PackageIdentifierRevision ident mcfi) = do-  -- FIXME make this more direct in the future-  m <- unpackPackageIdents unpackDir (Just distDir) [PackageIdentifierRevision ident mcfi]-  case Map.toList m of-    [(ident', dir)]-      | ident /= ident' -> error "unpackPackageIdent: ident mismatch"-      | otherwise       -> return dir-    [] -> error "unpackPackageIdent: empty list"-    _  -> error "unpackPackageIdent: multiple results"---- | 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-    :: HasCabalLoader env-    => Path Abs Dir -- ^ unpack directory-    -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157-    -> [PackageIdentifierRevision]-    -> RIO env (Map PackageIdentifier (Path Abs Dir))-unpackPackageIdents unpackDir mdistDir idents = do-    resolved <- resolvePackages Nothing idents Set.empty-    ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just unpackDir) resolved-    nowUnpacked <- fetchPackages' mdistDir toFetch-    return $ alreadyUnpacked <> nowUnpacked--data ResolvedPackage = ResolvedPackage-    { rpIdent :: !PackageIdentifier-    , rpDownload :: !(Maybe PackageDownload)-    , rpOffsetSize :: !OffsetSize-    , rpIndex :: !PackageIndex-    }-    deriving Show---- | Resolve a set of package names and identifiers into @FetchPackage@ values.-resolvePackages :: HasCabalLoader env-                => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan-                -> [PackageIdentifierRevision]-                -> Set PackageName-                -> RIO env [ResolvedPackage]-resolvePackages mSnapshotDef idents0 names0 = do-    eres <- go-    case eres of-        Left _ -> do-            updateAllIndices-            go >>= either throwM return-        Right x -> return x-  where-    go = r <$> getUses00Index <*> resolvePackagesAllowMissing mSnapshotDef idents0 names0-    r uses00Index (missingNames, missingIdents, idents)-      | not $ Set.null missingNames  = Left $ UnknownPackageNames       missingNames-      | not $ HashSet.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" uses00Index-      | otherwise                    = Right idents---- | Does the configuration use a 00-index.tar.gz file for indices?--- See <https://github.com/commercialhaskell/stack/issues/3520>-getUses00Index :: HasCabalLoader env => RIO env Bool-getUses00Index =-    any is00 <$> view (cabalLoaderL.to clIndices)-  where-    is00 :: PackageIndex -> Bool-    is00 index = "00-index.tar.gz" `T.isInfixOf` indexLocation index---- | Turn package identifiers and package names into a list of--- @ResolvedPackage@s. Returns any unresolved names and--- identifier. These are considered unresolved even if the only--- mismatch is in the cabal file info (MSS 2017-07-17: old versions of--- this code had special handling to treat missing cabal file info as--- a warning, that's no longer necessary or desirable since all info--- should be present and checked).-resolvePackagesAllowMissing-    :: forall env. HasCabalLoader env-    => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan-    -> [PackageIdentifierRevision]-    -> Set PackageName-    -> RIO env (Set PackageName, HashSet PackageIdentifierRevision, [ResolvedPackage])-resolvePackagesAllowMissing mSnapshotDef idents0 names0 = do-  cache@(PackageCache cache') <- getPackageCaches--      -- Find out the latest versions of all packages in the cache-  let versions = fmap (maximum . HashMap.keys) cache'--      -- Determines the identifier for a given name, either from-      -- snapshot information or by taking the latest version-      -- available-      getNamed :: PackageName -> Maybe PackageIdentifierRevision-      getNamed =-          case mSnapshotDef of-              Nothing -> getNamedFromIndex-              Just sd -> getNamedFromSnapshotDef sd--      -- Use whatever is specified in the snapshot. TODO this does not-      -- handle the case where a snapshot defines a package outside of-      -- the index, we'd need a LoadedSnapshot for that.-      getNamedFromSnapshotDef sd name = do-          loop $ sdLocations sd-        where-          loop [] = Nothing-          loop (PLIndex ident@(PackageIdentifierRevision (PackageIdentifier name' _) _):rest)-            | name == name' = Just ident-            | otherwise = loop rest-          loop (_:rest) = loop rest--      -- Take latest version available, including latest cabal file information-      getNamedFromIndex name = fmap-          (\ver -> PackageIdentifierRevision (PackageIdentifier name ver) CFILatest)-          (HashMap.lookup name versions)--      (missingNames, idents1) = partitionEithers $ map-          (\name -> maybe (Left name) Right (getNamed name))-          (Set.toList names0)-  cl <- view cabalLoaderL-  let (missingIdents, resolved) =-        partitionEithers-          $ map (\pir -> maybe (Left pir) Right (lookupResolvedPackage cl pir cache))-          $ idents0 <> idents1-  return (Set.fromList missingNames, HashSet.fromList missingIdents, resolved)--lookupResolvedPackage-  :: CabalLoader-  -> PackageIdentifierRevision-  -> PackageCache PackageIndex-  -> Maybe ResolvedPackage-lookupResolvedPackage cl (PackageIdentifierRevision ident@(PackageIdentifier name version) cfi) (PackageCache cache) = do-  (index, mdownload, files) <- HashMap.lookup name cache >>= HashMap.lookup version-  let moffsetSize =-        case cfi of-          CFILatest -> Just $ snd $ NE.last files-          CFIHash _msize hash' -> -- TODO check size?-              lookup hash'-            $ concatMap (\(hashes, x) -> map (, x) hashes)-            $ NE.toList files-          CFIRevision rev -> fmap snd $ listToMaybe $ drop (fromIntegral rev) $ NE.toList files-  offsetSize <--    case moffsetSize of-      Just x -> Just x-      Nothing-        | clIgnoreRevisionMismatch cl -> Just $ snd $ NE.last files-        | otherwise -> Nothing-  Just ResolvedPackage-    { rpIdent = ident-    , rpDownload = mdownload-    , rpOffsetSize = offsetSize-    , rpIndex = index-    }--data ToFetch = ToFetch-    { tfTarball :: !(Path Abs File)-    , tfDestDir :: !(Maybe (Path Abs Dir))-    , tfUrl     :: !T.Text-    , tfSize    :: !(Maybe Word64)-    , tfSHA256  :: !(Maybe StaticSHA256)-    , tfCabal   :: !ByteString-    -- ^ Contents of the .cabal file-    }--data ToFetchResult = ToFetchResult-    { tfrToFetch         :: !(Map PackageIdentifier ToFetch)-    , tfrAlreadyUnpacked :: !(Map PackageIdentifier (Path Abs Dir))-    }---- | Add the cabal files to a list of idents with their caches.-withCabalFiles-    :: HasCabalLoader env-    => IndexName-    -> [(ResolvedPackage, a)]-    -> (PackageIdentifier -> a -> ByteString -> IO b)-    -> RIO env [b]-withCabalFiles name pkgs f = do-    indexPath <- configPackageIndex name-    withBinaryFile (toFilePath indexPath) ReadMode-      $ \h -> mapM (goPkg h) pkgs-  where-    goPkg h (ResolvedPackage { rpIdent = ident, rpOffsetSize = OffsetSize offset size }, tf) = do-        -- Did not find warning for tarballs is handled above-        liftIO $ do-            hSeek h AbsoluteSeek $ fromIntegral offset-            cabalBS <- S.hGet h $ fromIntegral size-            f ident tf cabalBS--loadFromIndex :: HasCabalLoader env => PackageIdentifierRevision -> RIO env ByteString-loadFromIndex ident = do-  -- TODO in the future, keep all of the necessary @Handle@s open-  bothCaches <- getPackageCaches-  mres <- lookupPackageIdentifierExact ident bothCaches-  case mres of-      Just bs -> return bs-      -- Update the cache and try again-      Nothing -> do-          let fuzzy = fuzzyLookupCandidates ident bothCaches-              suggestions = case fuzzy of-                  FRNameNotFound Nothing -> ""-                  FRNameNotFound (Just cs) ->-                        "Perhaps you meant " <> orSeparated cs <> "?"-                  FRVersionNotFound cs -> "Possible candidates: " <>-                    commaSeparated (NE.map packageIdentifierText cs)-                    <> "."-                  FRRevisionNotFound cs ->-                    "The specified revision was not found.\nPossible candidates: " <>-                    commaSeparated (NE.map (T.pack . packageIdentifierRevisionString) cs)-                    <> "."-          cl <- view cabalLoaderL-          join $ modifyMVar (clUpdateRef cl) $ \toUpdate ->-              if toUpdate then do-                  logInfo $-                      "Didn't see " <>-                      fromString (packageIdentifierRevisionString ident) <>-                      " in your package indices.\n" <>-                      "Updating and trying again."-                  updateAllIndices-                  _ <- getPackageCaches-                  return (False, loadFromIndex ident)-              else do-                uses00Index <- getUses00Index-                return (toUpdate, throwIO $ UnknownPackageIdentifiers-                             (HashSet.singleton ident) (T.unpack suggestions) uses00Index)--lookupPackageIdentifierExact-  :: HasCabalLoader env-  => PackageIdentifierRevision-  -> PackageCache PackageIndex-  -> RIO env (Maybe ByteString)-lookupPackageIdentifierExact identRev cache = do-  cl <- view cabalLoaderL-  case lookupResolvedPackage cl identRev cache of-    Nothing -> return Nothing-    Just rp -> do-      bss <- withCabalFiles (indexName (rpIndex rp)) [(rp, ())] $ \_ _ bs -> return bs-      case bss of-        [bs] -> return (Just bs)-        _ -> return Nothing--data FuzzyResults-  = FRNameNotFound !(Maybe (NonEmpty T.Text))-  | FRVersionNotFound !(NonEmpty PackageIdentifier)-  | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision)---- | Given package identifier and package caches, return list of packages--- with the same name and the same two first version number components found--- in the caches.-fuzzyLookupCandidates-  :: PackageIdentifierRevision-  -> PackageCache index-  -> FuzzyResults-fuzzyLookupCandidates (PackageIdentifierRevision (PackageIdentifier name ver) _rev) (PackageCache caches) =-  case HashMap.lookup name caches of-    Nothing -> FRNameNotFound $ typoCorrectionCandidates name (PackageCache caches)-    Just m ->-      case HashMap.lookup ver m of-        Nothing ->-          case NE.nonEmpty $ filter sameMajor $ HashMap.keys m of-            Just vers -> FRVersionNotFound $ NE.map (PackageIdentifier name) vers-            Nothing ->-              case NE.nonEmpty $ HashMap.keys m of-                Nothing -> error "fuzzyLookupCandidates: no versions"-                Just vers -> FRVersionNotFound $ NE.map (PackageIdentifier name) vers-        Just (_index, _mpd, revisions) ->-          let hashes = concatMap fst $ NE.toList revisions-              pirs = map (PackageIdentifierRevision (PackageIdentifier name ver) . CFIHash Nothing) hashes-           in case NE.nonEmpty pirs of-                Nothing -> error "fuzzyLookupCandidates: no revisions"-                Just pirs' -> FRRevisionNotFound pirs'-  where-    sameMajor v = toMajorVersion v == toMajorVersion ver---- | Try to come up with typo corrections for given package identifier using--- package caches. This should be called before giving up, i.e. when--- 'fuzzyLookupCandidates' cannot return anything.-typoCorrectionCandidates-  :: PackageName-  -> PackageCache index-  -> Maybe (NonEmpty T.Text)-typoCorrectionCandidates name' (PackageCache cache) =-  let name = packageNameText name'-  in  NE.nonEmpty-    . take 10-    . map snd-    . filter (\(distance, _) -> distance < 4)-    . map (\k -> (damerauLevenshtein name (packageNameText k), packageNameText k))-    . HashMap.keys-    $ cache---- | Figure out where to fetch from.-getToFetch :: HasCabalLoader env-           => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack-           -> [ResolvedPackage]-           -> RIO env ToFetchResult-getToFetch mdest resolvedAll = do-    (toFetch0, unpacked) <- liftM partitionEithers $ mapM checkUnpacked resolvedAll-    toFetch1 <- mapM goIndex $ Map.toList $ Map.fromListWith (++) toFetch0-    return ToFetchResult-        { tfrToFetch = Map.unions toFetch1-        , tfrAlreadyUnpacked = Map.fromList unpacked-        }-  where-    checkUnpacked resolved = do-        let ident = rpIdent resolved-        dirRel <- parseRelDir $ packageIdentifierString ident-        let mdestDir = (</> dirRel) <$> mdest-        mexists <--            case mdestDir of-                Nothing -> return Nothing-                Just destDir -> do-                    exists <- doesDirExist destDir-                    return $ if exists then Just destDir else Nothing-        case mexists of-            Just destDir -> return $ Right (ident, destDir)-            Nothing -> do-                let index = rpIndex resolved-                    d = rpDownload resolved-                    targz = T.pack $ packageIdentifierString ident ++ ".tar.gz"-                tarball <- configPackageTarball (indexName index) ident-                return $ Left (indexName index, [(resolved, ToFetch-                    { tfTarball = tarball-                    , tfDestDir = mdestDir-                    , tfUrl = case fmap pdUrl d of-                        Just url | not (S.null url) -> decodeUtf8 url-                        _ -> indexDownloadPrefix index <> targz-                    , tfSize = fmap pdSize d-                    , tfSHA256 = fmap pdSHA256 d-                    , tfCabal = S.empty -- filled in by goIndex-                    })])--    goIndex (name, pkgs) =-        liftM Map.fromList $-        withCabalFiles name pkgs $ \ident tf cabalBS ->-        return (ident, tf { tfCabal = cabalBS })---- | Download the given name,version pairs into the directory expected by cabal.------ For each package it downloads, it will optionally unpack it to the given--- @Path@ (if present). Note that unpacking is not simply a matter of--- untarring, but also of grabbing the cabal file from the package index. The--- destinations should not include package identifiers.------ Returns the list of paths unpacked, including package identifiers. E.g.:------ @--- fetchPackages [("foo-1.2.3", Just "/some/dest")] ==> ["/some/dest/foo-1.2.3"]--- @------ Since 0.1.0.0-fetchPackages' :: forall env. HasCabalLoader env-               => Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157-               -> Map PackageIdentifier ToFetch-               -> RIO env (Map PackageIdentifier (Path Abs Dir))-fetchPackages' mdistDir toFetchAll = do-    connCount <- view $ cabalLoaderL.to clConnectionCount-    outputVar <- newTVarIO Map.empty--    parMapM_-        connCount-        (go outputVar)-        (Map.toList toFetchAll)--    readTVarIO outputVar-  where-    go :: TVar (Map PackageIdentifier (Path Abs Dir))-       -> (PackageIdentifier, ToFetch)-       -> RIO env ()-    go outputVar (ident, toFetch) = do-        req <- parseUrlThrow $ T.unpack $ tfUrl toFetch-        let destpath = tfTarball toFetch--        let toHashCheck bs = HashCheck SHA256 (CheckHexDigestByteString bs)-        let downloadReq = DownloadRequest-                { drRequest = req-                , drHashChecks = map (toHashCheck . staticSHA256ToBase16) $ maybeToList (tfSHA256 toFetch)-                , drLengthCheck = fromIntegral <$> tfSize toFetch-                , drRetryPolicy = drRetryPolicyDefault-                }-        let progressSink _ =-                logInfo $ display ident <> ": download"-        _ <- verifiedDownload downloadReq destpath progressSink--        identStrP <- parseRelDir $ packageIdentifierString ident--        F.forM_ (tfDestDir toFetch) $ \destDir -> do-            let innerDest = toFilePath destDir--            unexpectedEntries <- liftIO $ untar destpath identStrP (parent destDir)--            liftIO $ do-                case mdistDir of-                    Nothing -> return ()-                    -- See: https://github.com/fpco/stack/issues/157-                    Just distDir -> do-                        let inner = parent destDir </> identStrP-                            oldDist = inner </> $(mkRelDir "dist")-                            newDist = inner </> distDir-                        exists <- doesDirExist oldDist-                        when exists $ do-                            -- Previously used takeDirectory, but that got confused-                            -- by trailing slashes, see:-                            -- https://github.com/commercialhaskell/stack/issues/216-                            ---                            -- Instead, use Path which is a bit more resilient-                            ensureDir $ parent newDist-                            renameDir oldDist newDist--                let cabalFP =-                        innerDest FP.</>-                        packageNameString (packageIdentifierName ident)-                        FP.<.> "cabal"-                S.writeFile cabalFP $ tfCabal toFetch--                atomically $ modifyTVar outputVar $ Map.insert ident destDir--            F.forM_ unexpectedEntries $ \(path, entryType) ->-                logWarn $ "Unexpected entry type " <> display entryType <> " for entry " <> fromString path---- | Internal function used to unpack tarball.------ Takes a path to a .tar.gz file, the name of the directory it should contain,--- and a destination folder to extract the tarball into. Returns unexpected--- entries, as pairs of paths and descriptions.-untar :: forall b1 b2. Path b1 File -> Path Rel Dir -> Path b2 Dir -> IO [(FilePath, T.Text)]-untar tarPath expectedTarFolder destDirParent = do-  ensureDir destDirParent-  withLazyFile (toFilePath tarPath) $ \lbs -> do-                let rawEntries = fmap (either wrap wrap)-                            $ Tar.checkTarbomb (toFilePathNoTrailingSep expectedTarFolder)-                            $ Tar.read $ decompress lbs--                    filterEntries-                      :: (Semigroup w, Monoid w) => (Tar.Entry -> (Bool, w))-                         -> Tar.Entries b -> (Tar.Entries b, w)-                    -- Allow collecting warnings, Writer-monad style.-                    filterEntries f =-                      Tar.foldEntries-                        (\e -> let (res, w) = f e in-                            \(rest, wOld) -> ((if res then Tar.Next e else id) rest, wOld <> w))-                        (Tar.Done, mempty)-                        (\err -> (Tar.Fail err, mempty))--                    extractableEntry e =-                      case Tar.entryContent e of-                        Tar.NormalFile _ _ -> (True, [])-                        Tar.Directory -> (True, [])-                        Tar.SymbolicLink _ -> (True, [])-                        Tar.HardLink _ -> (True, [])-                        Tar.OtherEntryType 'g' _ _ -> (False, [])-                        Tar.OtherEntryType 'x' _ _ -> (False, [])-                        Tar.CharacterDevice _ _ -> (False, [(path, "character device")])-                        Tar.BlockDevice _ _ -> (False, [(path, "block device")])-                        Tar.NamedPipe -> (False, [(path, "named pipe")])-                        Tar.OtherEntryType code _ _ -> (False, [(path, "other entry type with code " <> T.pack (show code))])-                        where-                          path = Tar.fromTarPath $ Tar.entryTarPath e-                    (entries, unexpectedEntries) = filterEntries extractableEntry rawEntries--                    wrap :: Exception e => e -> FetchException-                    wrap = Couldn'tReadPackageTarball (toFilePath tarPath) . toException--                    getPerms :: Tar.Entry -> (FilePath, Tar.Permissions)-                    getPerms e = (toFilePath destDirParent FP.</> Tar.fromTarPath (Tar.entryTarPath e),-                                  Tar.entryPermissions e)--                    filePerms :: [(FilePath, Tar.Permissions)]-                    filePerms = catMaybes $ Tar.foldEntries (\e -> (:) (Just $ getPerms e))-                                                            [] (const []) entries-                Tar.unpack (toFilePath destDirParent) entries-                -- Reset file permissions as they were in the tarball, but only-                -- for extracted entries (whence filterEntries extractableEntry above).-                -- See https://github.com/commercialhaskell/stack/issues/2361-                mapM_ (\(fp, perm) -> setFileMode-                    (FP.dropTrailingPathSeparator fp)-                    perm) filePerms-                return unexpectedEntries--parMapM_ :: (F.Foldable f,MonadUnliftIO m)-         => Int-         -> (a -> m ())-         -> f a-         -> m ()-parMapM_ (max 1 -> 1) f xs = F.mapM_ f xs-parMapM_ cnt f xs0 = withRunInIO $ \run -> do-    var <- newTVarIO $ F.toList xs0--    replicateConcurrently_ cnt $ fix $ \loop -> join $ atomically $ do-      xs <- readTVar var-      case xs of-          [] -> return $ return ()-          x:xs' -> do-              writeTVar var xs'-              return $ do-                  run $ f x-                  loop--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 = T.intercalate ", " (NE.init xs) <> ", or " <> NE.last xs--commaSeparated :: NonEmpty T.Text -> T.Text-commaSeparated = F.fold . NE.intersperse ", "---- | Location of a package tarball-configPackageTarball :: HasCabalLoader env => IndexName -> PackageIdentifier -> RIO env (Path Abs File)-configPackageTarball iname ident = do-    root <- configPackageIndexRoot iname-    name <- parseRelDir $ packageNameString $ packageIdentifierName ident-    ver <- parseRelDir $ versionString $ packageIdentifierVersion ident-    base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz"-    return (root </> $(mkRelDir "packages") </> name </> ver </> base)
src/Stack/FileWatch.hs view
@@ -14,27 +14,31 @@ import Path import System.FSNotify import System.IO (hPutStrLn, getLine)+import System.Terminal -fileWatch :: Handle-          -> ((Set (Path Abs File) -> IO ()) -> IO ())-          -> IO ()+fileWatch+  :: Handle+  -> ((Set (Path Abs File) -> IO ()) -> RIO env ())+  -> RIO env () fileWatch = fileWatchConf defaultConfig -fileWatchPoll :: Handle-              -> ((Set (Path Abs File) -> IO ()) -> IO ())-              -> IO ()+fileWatchPoll+  :: Handle+  -> ((Set (Path Abs File) -> IO ()) -> RIO env ())+  -> RIO env () fileWatchPoll = fileWatchConf $ defaultConfig { confUsePolling = True }  -- | Run an action, watching for file changes -- -- The action provided takes a callback that is used to set the files to be -- watched. When any of those files are changed, we rerun the action again.-fileWatchConf :: WatchConfig-              -> Handle-              -> ((Set (Path Abs File) -> IO ()) -> IO ())-              -> IO ()-fileWatchConf cfg out inner = withManagerConf cfg $ \manager -> do-    let putLn = hPutStrLn out+fileWatchConf+  :: WatchConfig+  -> Handle+  -> ((Set (Path Abs File) -> IO ()) -> RIO env ())+  -> RIO env ()+fileWatchConf cfg out inner = withRunInIO $ \run -> withManagerConf cfg $ \manager -> do+    let putLn = hPutStrLn out -- FIXME     outputIsTerminal <- hIsTerminalDeviceOrMinTTY out     let withColor color str = putLn $ do             if outputIsTerminal@@ -113,7 +117,7 @@             dirty <- readTVar dirtyVar             check dirty -        eres <- tryAny $ inner setWatched+        eres <- tryAny $ run $ inner setWatched          -- Clear dirtiness flag after the build to avoid an infinite         -- loop caused by the build itself triggering dirtiness. This
+ src/Stack/Freeze.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Stack.Freeze+    ( freeze+    , FreezeOpts (..)+    , FreezeMode (..)+    ) where++import           Data.Aeson ((.=), object)+import qualified Data.Yaml as Yaml+import           RIO.Process+import qualified RIO.ByteString as B+import           Stack.Prelude+import           Stack.Types.Config++data FreezeMode = FreezeProject | FreezeSnapshot++newtype FreezeOpts = FreezeOpts+    { freezeMode :: FreezeMode+    }++freeze :: HasEnvConfig env => FreezeOpts -> RIO env ()+freeze (FreezeOpts mode) = do+  mproject <- view $ configL.to configProject+  let warn = logWarn "No project was found: nothing to freeze"+  case mproject of+    PCProject (p, _) -> doFreeze p mode+    PCGlobalProject -> warn+    PCNoProject _ -> warn++doFreeze ::+       (HasProcessContext env, HasLogFunc env, HasPantryConfig env)+    => Project+    -> FreezeMode+    -> RIO env ()+doFreeze p FreezeProject = do+  let deps = projectDependencies p+      resolver = projectResolver p+      completePackageLocation' pl =+        case pl of+          RPLImmutable pli -> PLImmutable <$> completePackageLocation pli+          RPLMutable m -> pure $ PLMutable m+  resolver' <- completeSnapshotLocation resolver+  deps' <- mapM completePackageLocation' deps+  let rawCompleted = map toRawPL deps'+      rawResolver = toRawSL resolver'+  if rawCompleted == deps && rawResolver == resolver+  then+    logInfo "No freezing is required for this project"+  else do+    logInfo "# Fields not mentioned below do not need to be updated"++    if rawResolver == resolver+      then logInfo "# No update to resolver is needed"+      else do+        logInfo "# Frozen version of resolver"+        B.putStr $ Yaml.encode $ object ["resolver" .= rawResolver]++    if rawCompleted == deps+      then logInfo "# No update to extra-deps is needed"+      else do+        logInfo "# Frozen version of extra-deps"+        B.putStr $ Yaml.encode $ object ["extra-deps" .= rawCompleted]++doFreeze p FreezeSnapshot = do+  resolver <- completeSnapshotLocation $ projectResolver p+  result <- loadSnapshotLayer resolver+  case result of+    Left _wc ->+      logInfo "No freezing is required for compiler resolver"+    Right snap -> do+      snap' <- completeSnapshotLayer snap+      let rawCompleted = toRawSnapshotLayer snap'+      if rawCompleted == snap+        then+        logInfo "No freezing is required for the snapshot of this project"+        else+        liftIO $ B.putStr $ Yaml.encode snap'
src/Stack/GhcPkg.hs view
@@ -1,12 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS -fno-warn-unused-do-bind #-}  -- | Functions for the GHC package database. @@ -14,9 +9,7 @@   (getGlobalDB   ,findGhcPkgField   ,createDatabase-  ,unregisterGhcPkgId-  ,getCabalPkgVer-  ,ghcPkgExeName+  ,unregisterGhcPkgIds   ,ghcPkgPathEnvVar   ,mkGhcPackagePath)   where@@ -25,29 +18,29 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as BL import           Data.List+import           Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T-import           Path (parent, mkRelFile, (</>))+import           Path (parent, (</>)) import           Path.Extra (toFilePathNoTrailingSep) import           Path.IO import           Stack.Constants-import           Stack.Types.Build+import           Stack.Types.Config (GhcPkgExe (..)) import           Stack.Types.GhcPkgId-import           Stack.Types.PackageIdentifier import           Stack.Types.Compiler-import           Stack.Types.PackageName-import           Stack.Types.Version import           System.FilePath (searchPathSeparator) import           RIO.Process  -- | Get the global package database-getGlobalDB :: (HasProcessContext env, HasLogFunc env)-            => WhichCompiler -> RIO env (Path Abs Dir)-getGlobalDB wc = do+getGlobalDB+  :: (HasProcessContext env, HasLogFunc env)+  => GhcPkgExe+  -> RIO env (Path Abs Dir)+getGlobalDB pkgexe = do     logDebug "Getting global package database location"     -- This seems like a strange way to get the global package database     -- location, but I don't know of a better one-    bs <- ghcPkg wc [] ["list", "--global"] >>= either throwIO return+    bs <- ghcPkg pkgexe [] ["list", "--global"] >>= either throwIO return     let fp = S8.unpack $ stripTrailingColon $ firstLine bs     liftIO $ resolveDir' fp   where@@ -58,30 +51,32 @@     firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n')  -- | Run the ghc-pkg executable-ghcPkg :: (HasProcessContext env, HasLogFunc env)-       => WhichCompiler-       -> [Path Abs Dir]-       -> [String]-       -> RIO env (Either SomeException S8.ByteString)-ghcPkg wc pkgDbs args = do+ghcPkg+  :: (HasProcessContext env, HasLogFunc env)+  => GhcPkgExe+  -> [Path Abs Dir]+  -> [String]+  -> RIO env (Either SomeException S8.ByteString)+ghcPkg pkgexe@(GhcPkgExe pkgPath) pkgDbs args = do     eres <- go     case eres of       Left _ -> do-        mapM_ (createDatabase wc) pkgDbs+        mapM_ (createDatabase pkgexe) pkgDbs         go       Right _ -> return eres   where-    go = tryAny-       $ BL.toStrict . fst-     <$> proc (ghcPkgExeName wc) args' readProcess_+    pkg = toFilePath pkgPath+    go = tryAny $ BL.toStrict . fst <$> proc pkg args' readProcess_     args' = packageDbFlags pkgDbs ++ args  -- | Create a package database in the given directory, if it doesn't exist. createDatabase   :: (HasProcessContext env, HasLogFunc env)-  => WhichCompiler -> Path Abs Dir -> RIO env ()-createDatabase wc db = do-    exists <- doesFileExist (db </> $(mkRelFile "package.cache"))+  => GhcPkgExe+  -> Path Abs Dir+  -> RIO env ()+createDatabase (GhcPkgExe pkgPath) db = do+    exists <- doesFileExist (db </> relFilePackageCache)     unless exists $ do         -- ghc-pkg requires that the database directory does not exist         -- yet. If the directory exists but the package.cache file@@ -101,15 +96,10 @@                 -- finding out it isn't the hard way                 ensureDir (parent db)                 return ["init", toFilePath db]-        void $ proc (ghcPkgExeName wc) args $ \pc ->+        void $ proc (toFilePath pkgPath) args $ \pc ->           readProcess_ pc `onException`           logError ("Unable to create package database at " <> fromString (toFilePath db)) --- | Get the name to use for "ghc-pkg", given the compiler version.-ghcPkgExeName :: WhichCompiler -> String-ghcPkgExeName Ghc = "ghc-pkg"-ghcPkgExeName Ghcjs = "ghcjs-pkg"- -- | Get the environment variable to use for the package DB paths. ghcPkgPathEnvVar :: WhichCompiler -> Text ghcPkgPathEnvVar Ghc = "GHC_PACKAGE_PATH"@@ -124,15 +114,15 @@ -- | Get the value of a field of the package. findGhcPkgField     :: (HasProcessContext env, HasLogFunc env)-    => WhichCompiler+    => GhcPkgExe     -> [Path Abs Dir] -- ^ package databases     -> String -- ^ package identifier, or GhcPkgId     -> Text     -> RIO env (Maybe Text)-findGhcPkgField wc pkgDbs name field = do+findGhcPkgField pkgexe pkgDbs name field = do     result <-         ghcPkg-            wc+            pkgexe             pkgDbs             ["field", "--simple-output", name, T.unpack field]     return $@@ -141,48 +131,25 @@             Right bs ->                 fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs --- | Get the version of the package-findGhcPkgVersion :: (HasProcessContext env, HasLogFunc env)-                  => WhichCompiler-                  -> [Path Abs Dir] -- ^ package databases-                  -> PackageName-                  -> RIO env (Maybe Version)-findGhcPkgVersion wc pkgDbs name = do-    mv <- findGhcPkgField wc pkgDbs (packageNameString name) "version"-    case mv of-        Just !v -> return (parseVersion v)-        _ -> return Nothing--unregisterGhcPkgId :: (HasProcessContext env, HasLogFunc env)-                    => WhichCompiler-                    -> CompilerVersion 'CVActual-                    -> Path Abs Dir -- ^ package database-                    -> GhcPkgId-                    -> PackageIdentifier-                    -> RIO env ()-unregisterGhcPkgId wc cv pkgDb gid ident = do-    eres <- ghcPkg wc [pkgDb] args+-- | unregister list of package ghcids, batching available from GHC 8.0.1,+-- using GHC package id where available (from GHC 7.9)+unregisterGhcPkgIds+  :: (HasProcessContext env, HasLogFunc env)+  => GhcPkgExe+  -> Path Abs Dir -- ^ package database+  -> NonEmpty (Either PackageIdentifier GhcPkgId)+  -> RIO env ()+unregisterGhcPkgIds pkgexe pkgDb epgids = do+    eres <- ghcPkg pkgexe [pkgDb] args     case eres of         Left e -> logWarn $ displayShow e         Right _ -> return ()   where-    -- TODO ideally we'd tell ghc-pkg a GhcPkgId instead     args = "unregister" : "--user" : "--force" :-        (case cv of-            GhcVersion v | v < $(mkVersion "7.9") ->-                [packageIdentifierString ident]-            _ -> ["--ipid", ghcPkgIdString gid])---- | Get the version of Cabal from the global package database.-getCabalPkgVer :: (HasProcessContext env, HasLogFunc env)-               => WhichCompiler -> RIO env Version-getCabalPkgVer wc = do-    logDebug "Getting Cabal package version"-    mres <- findGhcPkgVersion-        wc-        [] -- global DB-        cabalPackageName-    maybe (throwIO $ Couldn'tFindPkgId cabalPackageName) return mres+        concatMap (either+            (\ident -> [packageIdentifierString ident])+            (\gid -> ["--ipid", ghcPkgIdString gid]))+            epgids  -- | Get the value for GHC_PACKAGE_PATH mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text
src/Stack/Ghci.hs view
@@ -1,11 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}  -- | Run a GHCi configured with the user's package(s).@@ -19,6 +17,7 @@  import           Stack.Prelude hiding (Display (..)) import           Control.Monad.State.Strict (State, execState, get, modify)+import           Data.ByteString.Builder (byteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as LBS import           Data.List@@ -32,38 +31,32 @@ import           Path.Extra (toFilePathNoTrailingSep) import           Path.IO hiding (withSystemTempDir) import qualified RIO+import           RIO.PrettyPrint import           RIO.Process (HasProcessContext, exec, proc, readProcess_) import           Stack.Build import           Stack.Build.Installed import           Stack.Build.Source import           Stack.Build.Target-import           Stack.Config (getLocalPackages)+import           Stack.Constants import           Stack.Constants.Config import           Stack.Ghci.Script import           Stack.Package-import           Stack.PrettyPrint+import           Stack.Setup (withNewLocalBuildTargets) import           Stack.Types.Build-import           Stack.Types.Compiler import           Stack.Types.Config-import           Stack.Types.FlagName import           Stack.Types.NamedComponent import           Stack.Types.Package-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Runner+import           Stack.Types.SourceMap import           System.IO (putStrLn) import           System.IO.Temp (getCanonicalTemporaryDirectory)--#ifndef WINDOWS-import qualified System.Posix.Files as Posix-#endif+import           System.Permissions (setScriptPerms)  -- | Command-line options for GHC. data GhciOpts = GhciOpts     { ghciTargets            :: ![Text]     , ghciArgs               :: ![String]-    , ghciGhcOptions         :: ![Text]-    , ghciFlags              :: !(Map (Maybe PackageName) (Map FlagName Bool))+    , ghciGhcOptions         :: ![String]+    , ghciFlags              :: !(Map ApplyCLIFlag (Map FlagName Bool))     , ghciGhcCommand         :: !(Maybe FilePath)     , ghciNoLoadModules      :: !Bool     , ghciAdditionalPackages :: ![String]@@ -76,14 +69,17 @@     } deriving Show  -- | Necessary information to load a package or its components.+--+-- NOTE: GhciPkgInfo has paths as list instead of a Set to preserve files order+-- as a workaround for bug https://ghc.haskell.org/trac/ghc/ticket/13786 data GhciPkgInfo = GhciPkgInfo     { ghciPkgName :: !PackageName     , ghciPkgOpts :: ![(NamedComponent, BuildInfoOpts)]     , ghciPkgDir :: !(Path Abs Dir)     , ghciPkgModules :: !ModuleMap-    , ghciPkgCFiles :: !(Set (Path Abs File)) -- ^ C files.-    , ghciPkgMainIs :: !(Map NamedComponent (Set (Path Abs File)))-    , ghciPkgTargetFiles :: !(Maybe (Set (Path Abs File)))+    , ghciPkgCFiles :: ![Path Abs File] -- ^ C files.+    , ghciPkgMainIs :: !(Map NamedComponent [Path Abs File])+    , ghciPkgTargetFiles :: !(Maybe [Path Abs File])     , ghciPkgPackage :: !Package     } deriving Show @@ -140,12 +136,23 @@             { boptsCLITargets = []             , boptsCLIFlags = ghciFlags             }-    -- Load source map, without explicit targets, to collect all info.-    (locals, sourceMap) <- loadSourceMap AllowNoTargets buildOptsCLI+    sourceMap <- view $ envConfigL.to envConfigSourceMap+    installMap <- toInstallMap sourceMap+    locals <- projectLocalPackages+    depLocals <- localDependencies+    let localMap =+          M.fromList [(packageName $ lpPackage lp, lp) | lp <- locals ++ depLocals]+        -- FIXME:qrilka this looks wrong to go back to SMActual+        sma = SMActual+             { smaCompiler = smCompiler sourceMap+             , smaProject = smProject sourceMap+             , smaDeps = smDeps sourceMap+             , smaGlobal = smGlobal sourceMap+             }     -- Parse --main-is argument.-    mainIsTargets <- parseMainIsTargets buildOptsCLI ghciMainIs+    mainIsTargets <- parseMainIsTargets buildOptsCLI sma ghciMainIs     -- Parse to either file targets or build targets-    etargets <- preprocessTargets buildOptsCLI ghciTargets+    etargets <- preprocessTargets buildOptsCLI sma ghciTargets     (inputTargets, mfileTargets) <- case etargets of         Right packageTargets -> return (packageTargets, Nothing)         Left rawFileTargets -> do@@ -156,7 +163,7 @@             (targetMap, fileInfo, extraFiles) <- findFileTargets locals rawFileTargets             return (targetMap, Just (fileInfo, extraFiles))     -- Get a list of all the local target packages.-    localTargets <- getAllLocalTargets opts inputTargets mainIsTargets sourceMap+    localTargets <- getAllLocalTargets opts inputTargets mainIsTargets localMap     -- Get a list of all the non-local target packages.     nonLocalTargets <- getAllNonLocalTargets inputTargets     -- Check if additional package arguments are sensible.@@ -174,21 +181,25 @@               -- why this is done again after the build. This could               -- potentially be done more efficiently, because all we               -- need is the location of main modules, not the rest.-              pkgs0 <- getGhciPkgInfos sourceMap addPkgs (fmap fst mfileTargets) pkgDescs+              pkgs0 <- getGhciPkgInfos installMap addPkgs (fmap fst mfileTargets) pkgDescs               figureOutMainFile bopts mainIsTargets localTargets pkgs0     -- Build required dependencies and setup local packages.-    stackYaml <- view stackYamlL-    buildDepsAndInitialSteps opts (map (packageNameText . fst) localTargets)-    targetWarnings stackYaml localTargets nonLocalTargets mfileTargets+    buildDepsAndInitialSteps opts (map (T.pack . packageNameString . fst) localTargets)+    targetWarnings localTargets nonLocalTargets mfileTargets     -- Load the list of modules _after_ building, to catch changes in     -- unlisted dependencies (#1180)-    pkgs <- getGhciPkgInfos sourceMap addPkgs (fmap fst mfileTargets) pkgDescs+    pkgs <- getGhciPkgInfos installMap addPkgs (fmap fst mfileTargets) pkgDescs     checkForIssues pkgs     -- Finally, do the invocation of ghci     runGhci opts localTargets mainFile pkgs (maybe [] snd mfileTargets) (nonLocalTargets ++ addPkgs) -preprocessTargets :: HasEnvConfig env => BuildOptsCLI -> [Text] -> RIO env (Either [Path Abs File] (Map PackageName Target))-preprocessTargets buildOptsCLI rawTargets = do+preprocessTargets+    :: HasEnvConfig env+    => BuildOptsCLI+    -> SMActual GlobalPackage+    -> [Text]+    -> RIO env (Either [Path Abs File] (Map PackageName Target))+preprocessTargets buildOptsCLI sma rawTargets = do     let (fileTargetsRaw, normalTargetsRaw) =             partition (\t -> ".hs" `T.isSuffixOf` t || ".lhs" `T.isSuffixOf` t)                       rawTargets@@ -205,33 +216,43 @@         else do             -- Try parsing targets before checking if both file and             -- module targets are specified (see issue#3342).-            (_,_,normalTargets) <- parseTargets AllowNoTargets buildOptsCLI { boptsCLITargets = normalTargetsRaw }+            let boptsCLI = buildOptsCLI { boptsCLITargets = normalTargetsRaw }+            normalTargets <- parseTargets AllowNoTargets False boptsCLI sma                 `catch` \ex -> case ex of                     TargetParseException xs -> throwM (GhciTargetParseException xs)                     _ -> throwM ex             unless (null fileTargetsRaw) $ throwM Can'tSpecifyFilesAndTargets-            return (Right normalTargets)+            return (Right $ smtTargets normalTargets) -parseMainIsTargets :: HasEnvConfig env => BuildOptsCLI -> Maybe Text -> RIO env (Maybe (Map PackageName Target))-parseMainIsTargets buildOptsCLI mtarget = forM mtarget $ \target -> do-     (_,_,targets) <- parseTargets AllowNoTargets buildOptsCLI-         { boptsCLITargets = [target] }-     return targets+parseMainIsTargets+     :: HasEnvConfig env+     => BuildOptsCLI+     -> SMActual GlobalPackage+     -> Maybe Text+     -> RIO env (Maybe (Map PackageName Target))+parseMainIsTargets buildOptsCLI sma mtarget = forM mtarget $ \target -> do+     let boptsCLI = buildOptsCLI { boptsCLITargets = [target] }+     targets <- parseTargets AllowNoTargets False boptsCLI sma+     return $ smtTargets targets +-- | Display PackageName + NamedComponent+displayPkgComponent :: (PackageName, NamedComponent) -> StyleDoc+displayPkgComponent = style PkgComponent . fromString . T.unpack . renderPkgComponent+ findFileTargets     :: HasEnvConfig env     => [LocalPackage]     -> [Path Abs File]-    -> RIO env (Map PackageName Target, Map PackageName (Set (Path Abs File)), [Path Abs File])+    -> RIO env (Map PackageName Target, Map PackageName [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)+        return (lp, M.map (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))+                                                       (filter (elem fp . snd) (M.toList files))                                   ) filePackages                 ) fileTargets     results <- forM foundFileTargetComponents $ \(fp, xs) ->@@ -239,22 +260,22 @@             [] -> do                 prettyWarn $ vsep                     [ "Couldn't find a component for file target" <+>-                      display fp <>+                      pretty fp <>                       ". This means that the correct ghc options might not be used."                     , "Attempting to load the file anyway."                     ]                 return $ Left fp             [x] -> do                 prettyInfo $-                    "Using configuration for" <+> display x <+>-                    "to load" <+> display fp+                    "Using configuration for" <+> displayPkgComponent x <+>+                    "to load" <+> pretty 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 <> "."+                    pretty fp <> ":" <+>+                    mconcat (intersperse ", " (map displayPkgComponent xs)) <> line <>+                    "Guessing the first one," <+> displayPkgComponent x <> "."                 return $ Right (fp, x)     let (extraFiles, associatedFiles) = partitionEithers results         targetMap =@@ -262,8 +283,8 @@             map (\(_, (name, comp)) -> M.singleton name (TargetComps (S.singleton comp)))                 associatedFiles         infoMap =-            foldl (M.unionWith S.union) M.empty $-            map (\(fp, (name, _)) -> M.singleton name (S.singleton fp))+            foldl (M.unionWith (<>)) M.empty $+            map (\(fp, (name, _)) -> M.singleton name [fp])                 associatedFiles     return (targetMap, infoMap, extraFiles) @@ -272,30 +293,29 @@     => GhciOpts     -> Map PackageName Target     -> Maybe (Map PackageName Target)-    -> SourceMap+    -> Map PackageName LocalPackage     -> RIO env [(PackageName, (Path Abs File, Target))]-getAllLocalTargets GhciOpts{..} targets0 mainIsTargets sourceMap = do+getAllLocalTargets GhciOpts{..} targets0 mainIsTargets localMap = 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 (unionTargets targets0) mainIsTargets-    packages <- lpProject <$> getLocalPackages+    packages <- view $ envConfigL.to envConfigSourceMap.to smProject     -- Find all of the packages that are directly demanded by the     -- targets.-    directlyWanted <--        forMaybeM (M.toList packages) $-        \(name, lpv) ->+    let directlyWanted = flip mapMaybe (M.toList packages) $+          \(name, pp) ->                 case M.lookup name targets of-                  Just simpleTargets -> return (Just (name, (lpvCabalFP lpv, simpleTargets)))-                  Nothing -> return Nothing+                  Just simpleTargets -> Just (name, (ppCabalFP pp, simpleTargets))+                  Nothing -> Nothing     -- Figure out-    let extraLoadDeps = getExtraLoadDeps ghciLoadLocalDeps sourceMap directlyWanted+    let extraLoadDeps = getExtraLoadDeps ghciLoadLocalDeps localMap directlyWanted     if (ghciSkipIntermediate && not ghciLoadLocalDeps) || null extraLoadDeps         then return directlyWanted         else do             let extraList =-                  mconcat $ intersperse ", " (map (RIO.display . fst) extraLoadDeps)+                  mconcat $ intersperse ", " (map (fromString . packageNameString . fst) extraLoadDeps)             if ghciLoadLocalDeps                 then logInfo $                   "The following libraries will also be loaded into GHCi because " <>@@ -312,22 +332,18 @@     :: Map PackageName Target     -> RIO env [PackageName] getAllNonLocalTargets targets = do-  let isNonLocal (TargetAll Dependency) = True+  let isNonLocal (TargetAll PTDependency) = True       isNonLocal _ = False   return $ map fst $ filter (isNonLocal . snd) (M.toList targets)  buildDepsAndInitialSteps :: HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()-buildDepsAndInitialSteps GhciOpts{..} targets0 = do-    let targets = targets0 ++ map T.pack ghciAdditionalPackages+buildDepsAndInitialSteps GhciOpts{..} localTargets = do+    let targets = localTargets ++ 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-            , boptsCLIFlags = ghciFlags-            , boptsCLIGhcOptions = ghciGhcOptions-            }+        -- only new local targets could appear here+        eres <- tryAny $ withNewLocalBuildTargets targets $ build Nothing         case eres of             Right () -> return ()             Left err -> do@@ -336,8 +352,8 @@  checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName] checkAdditionalPackages pkgs = forM pkgs $ \name -> do-    let mres = (packageIdentifierName <$> parsePackageIdentifierFromString name)-            <|> parsePackageNameFromString name+    let mres = (pkgName <$> parsePackageIdentifier name)+            <|> parsePackageNameThrowing name     maybe (throwM $ InvalidPackageOption name) return mres  runGhci@@ -351,7 +367,6 @@     -> RIO env () runGhci GhciOpts{..} targets mainFile pkgs extraFiles exposePackages = do     config <- view configL-    wc <- view $ actualCompilerVersionL.whichCompilerL     let pkgopts = hidePkgOpts ++ genOpts ++ ghcOpts         shouldHidePackages =           fromMaybe (not (null pkgs && null exposePackages)) ghciHidePackages@@ -388,17 +403,18 @@             , "-hidir=" <> toFilePathNoTrailingSep oiDir ]     logInfo $       "Configuring GHCi with the following packages: " <>-      mconcat (intersperse ", " (map (RIO.display . ghciPkgName) pkgs))+      mconcat (intersperse ", " (map (fromString . packageNameString . ghciPkgName) pkgs))+    compilerExeName <- view $ compilerPathsL.to cpCompiler.to toFilePath     let execGhci extras = do             menv <- liftIO $ configProcessContextSettings config defaultEnvSettings             withProcessContext menv $ exec-                 (fromMaybe (compilerExeName wc) ghciGhcCommand)+                 (fromMaybe compilerExeName ghciGhcCommand)                  (("--interactive" : ) $                  -- This initial "-i" resets the include directories to                  -- not include CWD. If there aren't any packages, CWD                  -- is included.                   (if null pkgs then id else ("-i" : )) $-                  odir <> pkgopts <> extras <> map T.unpack ghciGhcOptions <> ghciArgs)+                  odir <> pkgopts <> extras <> ghciGhcOptions <> ghciArgs)         -- TODO: Consider optimizing this check. Perhaps if no         -- "with-ghc" is specified, assume that it is not using intero.         checkIsIntero =@@ -409,7 +425,7 @@                 [_] -> do                     menv <- liftIO $ configProcessContextSettings config defaultEnvSettings                     output <- withProcessContext menv-                            $ runGrabFirstLine (fromMaybe (compilerExeName wc) ghciGhcCommand) ["--version"]+                            $ runGrabFirstLine (fromMaybe compilerExeName ghciGhcCommand) ["--version"]                     return $ "Intero" `isPrefixOf` output                 _ -> return False     -- Since usage of 'exec' does not return, we cannot do any cleanup@@ -419,7 +435,7 @@     -- effect of making it possible to copy the ghci invocation out of     -- the log and have it still work.     tmpDirectory <--        (</> $(mkRelDir "haskell-stack-ghci")) <$>+        (</> relDirHaskellStackGhci) <$>         (parseAbsDir =<< liftIO getCanonicalTemporaryDirectory)     ghciDir <- view ghciDirL     ensureDir ghciDir@@ -433,7 +449,7 @@             scriptOptions <- writeGhciScript tmpDirectory (renderScript isIntero pkgs mainFile ghciOnlyMain extraFiles)             execGhci (macrosOptions ++ scriptOptions) -writeMacrosFile :: HasRunner env => Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]+writeMacrosFile :: HasTerm env => Path Abs Dir -> [GhciPkgInfo] -> RIO env [String] writeMacrosFile outputDirectory pkgs = do     fps <- fmap (nubOrd . catMaybes . concat) $         forM pkgs $ \pkg -> forM (ghciPkgOpts pkg) $ \(_, bio) -> do@@ -442,17 +458,17 @@             if exists                 then return $ Just cabalMacros                 else do-                    prettyWarnL ["Didn't find expected autogen file:", display cabalMacros]+                    prettyWarnL ["Didn't find expected autogen file:", pretty cabalMacros]                     return Nothing     files <- liftIO $ mapM (S8.readFile . toFilePath) fps     if null files then return [] else do-        out <- liftIO $ writeHashedFile outputDirectory $(mkRelFile "cabal_macros.h") $+        out <- liftIO $ writeHashedFile outputDirectory relFileCabalMacrosH $             S8.concat $ map (<> "\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") files         return ["-optP-include", "-optP" <> toFilePath out]  writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m [String] writeGhciScript outputDirectory script = do-    scriptPath <- liftIO $ writeHashedFile outputDirectory $(mkRelFile "ghci-script") $+    scriptPath <- liftIO $ writeHashedFile outputDirectory relFileGhciScript $         LBS.toStrict $ scriptToLazyByteString script     let scriptFilePath = toFilePath scriptPath     setScriptPerms scriptFilePath@@ -466,7 +482,7 @@     alreadyExists <- doesFileExist outFile     unless alreadyExists $ do         ensureDir outDir-        S8.writeFile (toFilePath outFile) contents+        writeBinaryFileAtomic outFile $ byteString contents     return outFile  renderScript :: Bool -> [GhciPkgInfo] -> Maybe (Path Abs File) -> Bool -> [Path Abs File] -> GhciScript@@ -493,7 +509,7 @@ -- 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)+getFileTargets = concatMap (concat . maybeToList . ghciPkgTargetFiles)  -- | Figure out the main-is file to load based on the targets. Asks the -- user for input if there is more than one candidate main-is file.@@ -537,17 +553,20 @@                     M.toList $                     M.filterWithKey (\k _ -> k `S.member` wantedComponents)                                     (ghciPkgMainIs pkg)-                main <- S.toList mains+                main <- mains                 return (ghciPkgName pkg, component, main)               where                 wantedComponents =                     wantedPackageComponents bopts target (ghciPkgPackage pkg)     renderCandidate c@(pkgName,namedComponent,mainIs) =         let candidateIndex = T.pack . show . (+1) . fromMaybe 0 . elemIndex c+            pkgNameText = T.pack (packageNameString pkgName)         in  candidateIndex candidates <> ". Package `" <>-            packageNameText pkgName <>+            pkgNameText <>             "' component " <>-            renderComp namedComponent <>+            -- This is the format that can be directly copy-pasted as+            -- an argument to `stack ghci`.+            pkgNameText <> ":" <> renderComp namedComponent <>             " with main-is file: " <>             T.pack (toFilePath mainIs)     candidateIndices = take (length candidates) [1 :: Int ..]@@ -578,9 +597,9 @@             CTest name -> "test:" <> name             CBench name -> "bench:" <> name     sampleTargetArg (pkg,comp,_) =-        packageNameText pkg <> ":" <> renderComp comp+        T.pack (packageNameString pkg) <> ":" <> renderComp comp     sampleMainIsArg (pkg,comp,_) =-        "--main-is " <> packageNameText pkg <> ":" <> renderComp comp+        "--main-is " <> T.pack (packageNameString pkg) <> ":" <> renderComp comp  loadGhciPkgDescs     :: HasEnvConfig env@@ -601,14 +620,25 @@     -> RIO env GhciPkgDesc loadGhciPkgDesc buildOptsCLI name cabalfp target = do     econfig <- view envConfigL-    bconfig <- view buildConfigL     compilerVersion <- view actualCompilerVersionL-    let config =+    let SourceMap{..} = envConfigSourceMap econfig+        -- Currently this source map is being build with+        -- the default targets+        sourceMapGhcOptions = fromMaybe [] $+          (cpGhcOptions . ppCommon <$> M.lookup name smProject)+          <|>+          (cpGhcOptions . dpCommon <$> M.lookup name smDeps)+        sourceMapCabalConfigOpts = fromMaybe [] $+          (cpCabalConfigOpts . ppCommon <$> M.lookup name smProject)+          <|>+          (cpCabalConfigOpts . dpCommon <$> M.lookup name smDeps)+        config =             PackageConfig             { packageConfigEnableTests = True             , packageConfigEnableBenchmarks = True-            , packageConfigFlags = getLocalFlags bconfig buildOptsCLI name-            , packageConfigGhcOptions = getGhcOptions bconfig buildOptsCLI name True True+            , packageConfigFlags = getLocalFlags buildOptsCLI name+            , packageConfigGhcOptions = sourceMapGhcOptions+            , packageConfigCabalConfigOpts = sourceMapCabalConfigOpts             , packageConfigCompilerVersion = compilerVersion             , packageConfigPlatform = view platformL econfig             }@@ -616,11 +646,12 @@     -- wouldn't have figured out the cabalfp already. In the future:     -- retain that GenericPackageDescription in the relevant data     -- structures to avoid reparsing.-    (gpkgdesc, _cabalfp) <- readPackageUnresolvedDir (parent cabalfp) True+    (gpdio, _name, _cabalfp) <- loadCabalFilePath (parent cabalfp)+    gpkgdesc <- liftIO $ gpdio YesPrintWarnings      -- Source the package's *.buildinfo file created by configure if any. See     -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters-    buildinfofp <- parseRelFile (T.unpack (packageNameText name) ++ ".buildinfo")+    buildinfofp <- parseRelFile (packageNameString name ++ ".buildinfo")     hasDotBuildinfo <- doesFileExist (parent cabalfp </> buildinfofp)     let mbuildinfofp           | hasDotBuildinfo = Just (parent cabalfp </> buildinfofp)@@ -645,48 +676,41 @@  getGhciPkgInfos     :: HasEnvConfig env-    => SourceMap+    => InstallMap     -> [PackageName]-    -> Maybe (Map PackageName (Set (Path Abs File)))+    -> Maybe (Map PackageName [Path Abs File])     -> [GhciPkgDesc]     -> RIO env [GhciPkgInfo]-getGhciPkgInfos sourceMap addPkgs mfileTargets localTargets = do-    (installedMap, _, _, _) <- getInstalled-        GetInstalledOpts-            { getInstalledProfiling = False-            , getInstalledHaddock   = False-            , getInstalledSymbols   = False-            }-        sourceMap+getGhciPkgInfos installMap addPkgs mfileTargets localTargets = do+    (installedMap, _, _, _) <- getInstalled installMap     let localLibs =             [ packageName (ghciDescPkg desc)             | desc <- localTargets             , hasLocalComp isCLib (ghciDescTarget desc)             ]     forM localTargets $ \pkgDesc ->-      makeGhciPkgInfo sourceMap installedMap localLibs addPkgs mfileTargets pkgDesc+      makeGhciPkgInfo installMap installedMap localLibs addPkgs mfileTargets pkgDesc  -- | Make information necessary to load the given package in GHCi. makeGhciPkgInfo     :: HasEnvConfig env-    => SourceMap+    => InstallMap     -> InstalledMap     -> [PackageName]     -> [PackageName]-    -> Maybe (Map PackageName (Set (Path Abs File)))+    -> Maybe (Map PackageName [Path Abs File])     -> GhciPkgDesc     -> RIO env GhciPkgInfo-makeGhciPkgInfo sourceMap installedMap locals addPkgs mfileTargets pkgDesc = do+makeGhciPkgInfo installMap installedMap locals addPkgs mfileTargets pkgDesc = do     bopts <- view buildOptsL     let pkg = ghciDescPkg pkgDesc         cabalfp = ghciDescCabalFp pkgDesc         target = ghciDescTarget pkgDesc         name = packageName pkg-    (mods,files,opts) <- getPackageOpts (packageOpts pkg) sourceMap installedMap locals addPkgs cabalfp+    (mods,files,opts) <- getPackageOpts (packageOpts pkg) installMap installedMap locals addPkgs cabalfp     let filteredOpts = filterWanted opts         filterWanted = M.filterWithKey (\k _ -> k `S.member` allWanted)         allWanted = wantedPackageComponents bopts target pkg-        setMapMaybe f = S.fromList . mapMaybe f . S.toList     return         GhciPkgInfo         { ghciPkgName = name@@ -695,8 +719,8 @@         , ghciPkgModules = unionModuleMaps $           map (\(comp, mp) -> M.map (\fp -> M.singleton fp (S.singleton (packageName pkg, comp))) mp)               (M.toList (filterWanted mods))-        , ghciPkgMainIs = M.map (setMapMaybe dotCabalMainPath) files-        , ghciPkgCFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalCFilePath) files)))+        , ghciPkgMainIs = M.map (mapMaybe dotCabalMainPath) files+        , ghciPkgCFiles = mconcat (M.elems (filterWanted (M.map (mapMaybe dotCabalCFilePath) files)))         , ghciPkgTargetFiles = mfileTargets >>= M.lookup name         , ghciPkgPackage = pkg         }@@ -706,7 +730,7 @@ -- (differently). wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent wantedPackageComponents _ (TargetComps cs) _ = cs-wantedPackageComponents bopts (TargetAll ProjectPackage) pkg = S.fromList $+wantedPackageComponents bopts (TargetAll PTProject) pkg = S.fromList $     (case packageLibraries pkg of        NoLibraries -> []        HasLibraries names -> CLib : map CInternalLib (S.toList names)) ++@@ -790,7 +814,7 @@  -- TODO: Should this also tell the user the filepaths, not just the -- module name?-checkForDuplicateModules :: HasRunner env => [GhciPkgInfo] -> RIO env ()+checkForDuplicateModules :: HasTerm env => [GhciPkgInfo] -> RIO env () checkForDuplicateModules pkgs = do     unless (null duplicates) $ do         borderedWarning $ do@@ -803,46 +827,51 @@       filter (\(_, mp) -> M.size mp > 1) $       M.toList $       unionModuleMaps (map ghciPkgModules pkgs)-    prettyDuplicate :: (ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent))) -> AnsiDoc+    prettyDuplicate :: (ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent))) -> StyleDoc     prettyDuplicate (mn, mp) =-      styleError (display mn) <+> "found at the following paths" <> line <>+      style Error (pretty mn) <+> "found at the following paths" <> line <>       bulletedList (map fileDuplicate (M.toList mp))-    fileDuplicate :: (Path Abs File, Set (PackageName, NamedComponent)) -> AnsiDoc+    fileDuplicate :: (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc     fileDuplicate (fp, comps) =-      display fp <+> parens (fillSep (punctuate "," (map display (S.toList comps))))+      pretty fp <+> parens (fillSep (punctuate "," (map displayPkgComponent (S.toList comps))))  targetWarnings-  :: HasRunner env-  => Path Abs File-  -> [(PackageName, (Path Abs File, Target))]+  :: HasBuildConfig env+  => [(PackageName, (Path Abs File, Target))]   -> [PackageName]-  -> Maybe (Map PackageName (Set (Path Abs File)), [Path Abs File])+  -> Maybe (Map PackageName [Path Abs File], [Path Abs File])   -> RIO env ()-targetWarnings stackYaml localTargets nonLocalTargets mfileTargets = do+targetWarnings localTargets nonLocalTargets mfileTargets = do   unless (null nonLocalTargets) $     prettyWarnL       [ flow "Some targets"-      , parens $ fillSep $ punctuate "," $ map (styleGood . display) nonLocalTargets+      , parens $ fillSep $ punctuate "," $ map (style Good . fromString . packageNameString) nonLocalTargets       , flow "are not local packages, and so cannot be directly loaded."       , flow "In future versions of stack, this might be supported - see"-      , styleUrl "https://github.com/commercialhaskell/stack/issues/1441"+      , style Url "https://github.com/commercialhaskell/stack/issues/1441"       , "."       , flow "It can still be useful to specify these, as they will be passed to ghci via -package flags."       ]-  when (null localTargets && isNothing mfileTargets) $+  when (null localTargets && isNothing mfileTargets) $ do+      smWanted <- view $ buildConfigL.to bcSMWanted+      stackYaml <- view stackYamlL       prettyNote $ vsep           [ flow "No local targets specified, so a plain ghci will be started with no package hiding or package options."           , ""+          , flow $ T.unpack $ utf8BuilderToText $+                   "You are using snapshot: " <>+                   RIO.display (smwSnapshotLocation smWanted)+          , ""           , flow "If you want to use package hiding and options, then you can try one of the following:"           , ""           , bulletedList               [ fillSep-                  [ flow "If you want to start a different project configuration than" <+> display stackYaml <> ", then you can use"-                  , styleShell "stack init"+                  [ flow "If you want to start a different project configuration than" <+> pretty stackYaml <> ", then you can use"+                  , style Shell "stack init"                   , flow "to create a new stack.yaml for the packages in the current directory."                   , line                   ]-              , flow "If you want to use the project configuration at" <+> display stackYaml <> ", then you can add to its 'packages' field."+              , flow "If you want to use the project configuration at" <+> pretty stackYaml <> ", then you can add to its 'packages' field."               ]           , ""           ]@@ -856,10 +885,10 @@ -- if they aren't intermediate. getExtraLoadDeps     :: Bool-    -> SourceMap+    -> Map PackageName LocalPackage     -> [(PackageName, (Path Abs File, Target))]     -> [(PackageName, (Path Abs File, Target))]-getExtraLoadDeps loadAllDeps sourceMap targets =+getExtraLoadDeps loadAllDeps localMap targets =     M.toList $     (\mp -> foldl' (flip M.delete) mp (map fst targets)) $     M.mapMaybe id $@@ -868,16 +897,16 @@   where     getDeps :: PackageName -> [PackageName]     getDeps name =-        case M.lookup name sourceMap of-            Just (PSFiles lp _) -> M.keys (packageDeps (lpPackage lp)) -- FIXME just Local?+        case M.lookup name localMap of+            Just lp -> M.keys (packageDeps (lpPackage lp)) -- FIXME just Local?             _ -> []     go :: PackageName -> State (Map PackageName (Maybe (Path Abs File, Target))) Bool     go name = do         cache <- get-        case (M.lookup name cache, M.lookup name sourceMap) of+        case (M.lookup name cache, M.lookup name localMap) of             (Just (Just _), _) -> return True             (Just Nothing, _) | not loadAllDeps -> return False-            (_, Just (PSFiles lp _)) -> do+            (_, Just lp) -> do                 let deps = M.keys (packageDeps (lpPackage lp))                 shouldLoad <- liftM or $ mapM go deps                 if shouldLoad@@ -887,37 +916,22 @@                     else do                         modify (M.insert name Nothing)                         return False-            (_, Just PSIndex{}) -> return loadAllDeps             (_, _) -> return False -setScriptPerms :: MonadIO m => FilePath -> m ()-#ifdef WINDOWS-setScriptPerms _ = do-    return ()-#else-setScriptPerms fp = do-    liftIO $ Posix.setFileMode fp $ foldl1 Posix.unionFileModes-        [ Posix.ownerReadMode-        , Posix.ownerWriteMode-        , Posix.groupReadMode-        , Posix.otherReadMode-        ]-#endif- unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target unionTargets = M.unionWith $ \l r ->     case (l, r) of-        (TargetAll Dependency, _) -> r+        (TargetAll PTDependency, _) -> r         (TargetComps sl, TargetComps sr) -> TargetComps (S.union sl sr)-        (TargetComps _, TargetAll ProjectPackage) -> TargetAll ProjectPackage+        (TargetComps _, TargetAll PTProject) -> TargetAll PTProject         (TargetComps _, _) -> l-        (TargetAll ProjectPackage, _) -> TargetAll ProjectPackage+        (TargetAll PTProject, _) -> TargetAll PTProject  hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool hasLocalComp p t =     case t of         TargetComps s -> any p (S.toList s)-        TargetAll ProjectPackage -> True+        TargetAll PTProject -> True         _ -> False  -- | Run a command and grab the first line of stdout, dropping
src/Stack/Hoogle.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}  -- | A wrapper around hoogle. module Stack.Hoogle@@ -11,28 +10,31 @@ import           Stack.Prelude import qualified Data.ByteString.Lazy.Char8 as BL8 import           Data.Char (isSpace)-import           Data.List (find)-import qualified Data.Set as Set import qualified Data.Text as T+import           Distribution.Types.PackageName (mkPackageName)+import           Distribution.Version (mkVersion)+import           Lens.Micro ((?~)) import           Path (parseAbsFile) import           Path.IO hiding (findExecutable) import qualified Stack.Build-import           Stack.Fetch+import           Stack.Build.Target (NeedTargets(NeedTargets)) import           Stack.Runners import           Stack.Types.Config-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Version-import           System.Exit import           RIO.Process  -- | Hoogle command.-hoogleCmd :: ([String],Bool,Bool,Bool) -> GlobalOpts -> IO ()-hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do+hoogleCmd :: ([String],Bool,Bool,Bool) -> RIO Runner ()+hoogleCmd (args,setup,rebuild,startServer) =+  local (over globalOptsL modifyGO) $+  withConfig YesReexec $+  withDefaultEnvConfig $ do     hooglePath <- ensureHoogleInPath     generateDbIfNeeded hooglePath     runHoogle hooglePath args'   where+    modifyGO :: GlobalOpts -> GlobalOpts+    modifyGO = globalOptsBuildOptsMonoidL . buildOptsMonoidHaddockL ?~ True+     args' :: [String]     args' = if startServer                  then ["server", "--local", "--port", "8080"]@@ -63,82 +65,61 @@            createDirIfMissing True dir            runHoogle hooglePath ["generate", "--local"]     buildHaddocks :: RIO EnvConfig ()-    buildHaddocks =-        liftIO-            (catch-                 (withBuildConfigAndLock-                      (set-                           (globalOptsBuildOptsMonoidL . buildOptsMonoidHaddockL)-                           (Just True)-                           go)-                      (\lk ->-                            Stack.Build.build-                                (const (return ()))-                                lk-                                defaultBuildOptsCLI))-                 (\(_ :: ExitCode) ->-                       return ()))-    hooglePackageName = $(mkPackageName "hoogle")-    hoogleMinVersion = $(mkVersion "5.0")+    buildHaddocks = do+      config <- view configL+      runRIO config $ -- a bit weird that we have to drop down like this+        catch (withDefaultEnvConfig $ Stack.Build.build Nothing)+              (\(_ :: ExitCode) -> return ())+    hooglePackageName = mkPackageName "hoogle"+    hoogleMinVersion = mkVersion [5, 0]     hoogleMinIdent =         PackageIdentifier hooglePackageName hoogleMinVersion     installHoogle :: RIO EnvConfig ()     installHoogle = do-        hooglePackageIdentifier <--            do (_,_,resolved) <--                   resolvePackagesAllowMissing+        hooglePackageIdentifier <- do+          mversion <- getLatestHackageVersion YesRequireHackageIndex hooglePackageName UsePreferredVersions -                       -- FIXME this Nothing means "do not follow any-                       -- specific snapshot", which matches old-                       -- behavior. However, since introducing the-                       -- logic to pin a name to a package in a-                       -- snapshot, we may arguably want to ensure-                       -- that we're grabbing the version of Hoogle-                       -- present in the snapshot currently being-                       -- used.-                       Nothing+          -- FIXME For a while, we've been following the logic of+          -- taking the latest Hoogle version available. However, we+          -- may want to instead grab the version of Hoogle present in+          -- the snapshot current being used instead.+          pure $ fromMaybe (Left hoogleMinIdent) $ do+            pir@(PackageIdentifierRevision _ ver _) <- mversion+            guard $ ver >= hoogleMinVersion+            Just $ Right pir -                       mempty-                       (Set.fromList [hooglePackageName])-               return-                   (case find-                             ((== hooglePackageName) . packageIdentifierName)-                             (map rpIdent resolved) of-                        Just ident@(PackageIdentifier _ ver)-                          | ver >= hoogleMinVersion -> Right ident-                        _ -> Left hoogleMinIdent)         case hooglePackageIdentifier of             Left{} -> logInfo $               "Minimum " <>-              display hoogleMinIdent <>+              fromString (packageIdentifierString hoogleMinIdent) <>               " is not in your index. Installing the minimum version."             Right ident -> logInfo $               "Minimum version is " <>-              display hoogleMinIdent <>+              fromString (packageIdentifierString hoogleMinIdent) <>               ". Found acceptable " <>               display ident <>               " in your index, installing it."         config <- view configL         menv <- liftIO $ configProcessContextSettings config envSettings-        liftIO-            (catch-                 (withBuildConfigAndLock-                      go-                      (\lk ->-                            Stack.Build.build-                                (const (return ()))-                                lk-                                defaultBuildOptsCLI-                                { boptsCLITargets = [ packageIdentifierText-                                                          (either-                                                               id-                                                               id-                                                               hooglePackageIdentifier)]-                                }))+        let boptsCLI = defaultBuildOptsCLI+                { boptsCLITargets =+                    pure $+                    T.pack . packageIdentifierString $+                    either+                    id+                    (\(PackageIdentifierRevision n v _) -> PackageIdentifier n v)+                    hooglePackageIdentifier+                }+        runRIO config $ catch -- Also a bit weird+                 (withEnvConfig+                      NeedTargets+                      boptsCLI $+                      Stack.Build.build Nothing+                 )                  (\(e :: ExitCode) ->                        case e of                            ExitSuccess -> runRIO menv resetExeCache-                           _ -> throwIO e))+                           _ -> throwIO e)     runHoogle :: Path Abs File -> [String] -> RIO EnvConfig ()     runHoogle hooglePath hoogleArgs = do         config <- view configL@@ -150,7 +131,7 @@           (hoogleArgs ++ databaseArg)           runProcess_     bail :: RIO EnvConfig a-    bail = liftIO (System.Exit.exitWith (ExitFailure (-1)))+    bail = exitWith (ExitFailure (-1))     checkDatabaseExists = do         path <- hoogleDatabasePath         liftIO (doesFileExist path)@@ -173,7 +154,7 @@                         ]                 return $ case result of                     Left err -> unexpectedResult $ T.pack (show err)-                    Right bs -> case parseVersionFromString (takeWhile (not . isSpace) (BL8.unpack bs)) of+                    Right bs -> case parseVersion (takeWhile (not . isSpace) (BL8.unpack bs)) of                         Nothing -> unexpectedResult $ T.pack (BL8.unpack bs)                         Just ver                             | ver >= hoogleMinVersion -> Right hooglePath@@ -181,7 +162,7 @@                                 [ "Installed Hoogle is too old, "                                 , T.pack hooglePath                                 , " is version "-                                , versionText ver+                                , T.pack $ versionString ver                                 , " but >= 5.0 is required."                                 ]         case eres of
src/Stack/IDE.hs view
@@ -3,45 +3,57 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Functions for IDEs. module Stack.IDE-    ( listPackages+    ( OutputStream(..)+    , ListPackagesCmd(..)+    , listPackages     , listTargets     ) where  import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T-import           Stack.Config (getLocalPackages)-import           Stack.Package (readPackageUnresolvedDir, gpdPackageName) import           Stack.Prelude import           Stack.Types.Config import           Stack.Types.NamedComponent+import           Stack.Types.SourceMap+import           System.IO (putStrLn) +data OutputStream = OutputLogInfo+                  | OutputStdout++data ListPackagesCmd = ListPackageNames+                     | ListPackageCabalFiles++outputFunc :: HasLogFunc env => OutputStream -> String -> RIO env ()+outputFunc OutputLogInfo = logInfo . fromString+outputFunc OutputStdout  = liftIO . putStrLn+ -- | List the packages inside the current project.-listPackages :: HasEnvConfig env => RIO env ()-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 <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages-    forM_ packageDirs $ \dir -> do-        (gpd, _) <- readPackageUnresolvedDir dir False-        (logInfo . display) (gpdPackageName gpd)+listPackages :: HasBuildConfig env => OutputStream -> ListPackagesCmd -> RIO env ()+listPackages stream flag = do+  packages <- view $ buildConfigL.to (smwProject . bcSMWanted)+  let strs = case flag of+        ListPackageNames ->+          map packageNameString (Map.keys packages)+        ListPackageCabalFiles ->+          map (toFilePath . ppCabalFP) (Map.elems packages)+  mapM_ (outputFunc stream) strs  -- | List the targets in the current project.-listTargets :: HasEnvConfig env => RIO env ()-listTargets =-    do rawLocals <- lpProject <$> getLocalPackages-       logInfo $ display-           (T.intercalate-                "\n"-                (map-                     renderPkgComponent-                     (concatMap-                          toNameAndComponent-                          (Map.toList rawLocals))))+listTargets :: forall env. HasBuildConfig env => OutputStream -> RIO env ()+listTargets stream = do+  packages <- view $ buildConfigL.to (smwProject . bcSMWanted)+  pairs <- concat <$> Map.traverseWithKey toNameAndComponent packages+  outputFunc stream $ T.unpack $ T.intercalate "\n" $+    map renderPkgComponent pairs   where-    toNameAndComponent (pkgName,view') =-        map (pkgName, ) (Set.toList (lpvComponents view'))+    toNameAndComponent+      :: PackageName+      -> ProjectPackage+      -> RIO env [(PackageName, NamedComponent)]+    toNameAndComponent pkgName' =+        fmap (map (pkgName', ) . Set.toList) . ppComponents
− src/Stack/Image.hs 
@@ -1,222 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ConstraintKinds    #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE RecordWildCards    #-}-{-# LANGUAGE TemplateHaskell    #-}---- | This module builds Docker (OpenContainer) images.-module Stack.Image-       (stageContainerImageArtifacts, createContainerImageFromStage,-        imgCmdName, imgDockerCmdName, imgOptsFromMonoid)-       where--import           Stack.Prelude-import qualified Data.ByteString as B-import           Data.Char (toLower)-import qualified Data.Map.Strict as Map-import           Data.Text.Encoding (encodeUtf8)-import qualified Data.Text as T-import           Path-import           Path.Extra-import           Path.IO-import           Stack.Constants.Config-import           Stack.PrettyPrint-import           Stack.Types.Config-import           Stack.Types.Image-import           RIO.Process---- | Stages the executables & additional content in a staging--- directory under '.stack-work'-stageContainerImageArtifacts-    :: HasEnvConfig env-    => Maybe (Path Abs Dir) -> [Text] -> RIO env ()-stageContainerImageArtifacts mProjectRoot imageNames = do-    config <- view configL-    forM_-        (zip-             [0 ..]-             (filterImages-                  (map T.unpack imageNames)-                  (imgDockers $ configImage config)))-        (\(idx,opts) ->-              do imageDir <--                     imageStagingDir (fromMaybeProjectRoot mProjectRoot) idx-                 liftIO (ignoringAbsence (removeDirRecur imageDir))-                 ensureDir imageDir-                 stageExesInDir opts imageDir-                 syncAddContentToDir opts imageDir)---- | Builds a Docker (OpenContainer) image extending the `base` image--- specified in the project's stack.yaml.  Then new image will be--- extended with an ENTRYPOINT specified for each `entrypoint` listed--- in the config file.-createContainerImageFromStage-    :: HasConfig env-    => Maybe (Path Abs Dir) -> [Text] -> RIO env ()-createContainerImageFromStage mProjectRoot imageNames = do-    config <- view configL-    forM_-        (zip-             [0 ..]-             (filterImages-                  (map T.unpack imageNames)-                  (imgDockers $ configImage config)))-        (\(idx,opts) ->-              do imageDir <--                     imageStagingDir (fromMaybeProjectRoot mProjectRoot) idx-                 createDockerImage opts imageDir-                 extendDockerImageWithEntrypoint opts imageDir)--filterImages :: [String] -> [ImageDockerOpts] -> [ImageDockerOpts]-filterImages [] = id -- all: no filter-filterImages names = filter (imageNameFound . imgDockerImageName)-  where-    imageNameFound (Just name) = name `elem` names-    imageNameFound _ = False---- | Stage all the Package executables in the usr/local/bin--- subdirectory of a temp directory.-stageExesInDir-    :: HasEnvConfig env-    => ImageDockerOpts -> Path Abs Dir -> RIO env ()-stageExesInDir opts dir = do-    srcBinPath <- fmap (</> $(mkRelDir "bin")) installationRootLocal-    let destBinPath = dir </> $(mkRelDir "usr/local/bin")-    ensureDir destBinPath-    case imgDockerExecutables opts of-        Nothing -> do-            logInfo ""-            logInfo "Note: 'executables' not specified for a image container, so every executable in the project's local bin dir will be used."-            mcontents <- liftIO $ forgivingAbsence $ listDir srcBinPath-            case mcontents of-                Just (files, dirs)-                    | not (null files) || not (null dirs) -> liftIO $ copyDirRecur srcBinPath destBinPath-                _ -> prettyWarn "The project's local bin dir contains no files, so no executables will be added to the docker image."-            logInfo ""--        Just exes ->-            forM_-                exes-                (\exe ->-                      copyFile-                          (srcBinPath </> exe)-                          (destBinPath </> exe))---- | Add any additional files into the temp directory, respecting the--- (Source, Destination) mapping.-syncAddContentToDir-    :: HasEnvConfig env-    => ImageDockerOpts -> Path Abs Dir -> RIO env ()-syncAddContentToDir opts dir = do-    root <- view projectRootL-    let imgAdd = imgDockerAdd opts-    forM_-        (Map.toList imgAdd)-        (\(source,destPath) ->-              do sourcePath <- resolveDir root source-                 let destFullPath = dir </> dropRoot destPath-                 ensureDir destFullPath-                 liftIO $ copyDirRecur sourcePath destFullPath)---- | Derive an image name from the project directory.-imageName-    :: Path Abs Dir -> String-imageName = map toLower . toFilePathNoTrailingSep . dirname---- | Create a general purpose docker image from the temporary--- directory of executables & static content.-createDockerImage-    :: HasConfig env-    => ImageDockerOpts -> Path Abs Dir -> RIO env ()-createDockerImage dockerConfig dir =-    case imgDockerBase dockerConfig of-        Nothing -> throwM StackImageDockerBaseUnspecifiedException-        Just base -> do-            liftIO-                (B.writeFile-                     (toFilePath (dir </> $(mkRelFile "Dockerfile")))-                     (encodeUtf8 (T.pack (unlines ["FROM " ++ base, "ADD ./ /"]))))-            let args =-                    [ "build"-                    , "-t"-                    , fromMaybe-                          (imageName (parent . parent . parent $ dir))-                          (imgDockerImageName dockerConfig)-                    , toFilePathNoTrailingSep dir]-            proc "docker" args runProcess_---- | Extend the general purpose docker image with entrypoints (if specified).-extendDockerImageWithEntrypoint-    :: HasConfig env-    => ImageDockerOpts -> Path Abs Dir -> RIO env ()-extendDockerImageWithEntrypoint dockerConfig dir = do-    let dockerImageName =-            fromMaybe-                (imageName (parent . parent . parent $ dir))-                (imgDockerImageName dockerConfig)-    let imgEntrypoints = imgDockerEntrypoints dockerConfig-    case imgEntrypoints of-        Nothing -> return ()-        Just eps ->-            forM_-                eps-                (\ep ->-                      do liftIO-                             (B.writeFile-                                  (toFilePath-                                       (dir </> $(mkRelFile "Dockerfile")))-                                  (encodeUtf8 (T.pack (unlines-                                       [ "FROM " ++ dockerImageName-                                       , "ENTRYPOINT [\"/usr/local/bin/" ++-                                         ep ++ "\"]"-                                       , "CMD []"]))))-                         proc-                                  "docker"-                                  [ "build"-                                  , "-t"-                                  , dockerImageName ++ "-" ++ ep-                                  , toFilePathNoTrailingSep dir]-                                  runProcess_)---- | Fail with friendly error if project root not set.-fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir-fromMaybeProjectRoot =-    fromMaybe (impureThrow StackImageCannotDetermineProjectRootException)---- | The command name for dealing with images.-imgCmdName-    :: String-imgCmdName = "image"---- | The command name for building a docker container.-imgDockerCmdName-    :: String-imgDockerCmdName = "container"---- | Convert image opts monoid to image options.-imgOptsFromMonoid-    :: ImageOptsMonoid -> ImageOpts-imgOptsFromMonoid ImageOptsMonoid{..} =-    ImageOpts-    { imgDockers = imgMonoidDockers-    }---- | Stack image exceptions.-data StackImageException-    = StackImageDockerBaseUnspecifiedException  -- ^ Unspecified parent docker-                                                -- container makes building-                                                -- impossible-    | StackImageCannotDetermineProjectRootException  -- ^ Can't determine the-                                                     -- project root (where to-                                                     -- put image sandbox).-    deriving (Typeable)--instance Exception StackImageException--instance Show StackImageException where-    show StackImageDockerBaseUnspecifiedException =-        "You must specify a base docker image on which to place your haskell executables."-    show StackImageCannotDetermineProjectRootException =-        "Stack was unable to determine the project root in order to build a container."
src/Stack/Init.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-} module Stack.Init     ( initProject     , InitOpts (..)@@ -11,50 +13,46 @@ import           Stack.Prelude 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 qualified Data.HashMap.Strict             as HM import qualified Data.IntMap                     as IntMap-import           Data.List                       (intercalate, intersect,-                                                  maximumBy)+import           Data.List.Extra                 (groupSortOn) import           Data.List.NonEmpty              (NonEmpty (..)) import qualified Data.List.NonEmpty              as NonEmpty import qualified Data.Map.Strict                 as Map import qualified Data.Set                        as Set import qualified Data.Text                       as T+import qualified Data.Text.Normalize             as T (normalize , NormalizationMode(NFC)) 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           Path import           Path.Extra                      (toFilePathNoTrailingSep)-import           Path.IO+import           Path.Find                       (findFiles)+import           Path.IO                         hiding (findFiles) import qualified Paths_stack                     as Meta+import qualified RIO.FilePath                    as FP+import           RIO.List                        ((\\), intercalate, intersperse,+                                                  isSuffixOf, isPrefixOf)+import           RIO.List.Partial                (minimumBy) import           Stack.BuildPlan import           Stack.Config                    (getSnapshots,                                                   makeConcreteResolver) import           Stack.Constants-import           Stack.Snapshot                  (loadResolver)-import           Stack.Solver-import           Stack.Types.Build-import           Stack.Types.BuildPlan+import           Stack.SourceMap import           Stack.Types.Config-import           Stack.Types.FlagName-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName import           Stack.Types.Resolver import           Stack.Types.Version-import qualified System.FilePath                 as FP  -- | Generate stack.yaml initProject     :: (HasConfig env, HasGHCVariant env)-    => WhichSolverCmd-    -> Path Abs Dir+    => Path Abs Dir     -> InitOpts     -> Maybe AbstractResolver     -> RIO env ()-initProject whichCmd currDir initOpts mresolver = do+initProject currDir initOpts mresolver = do     let dest = currDir </> stackDotYaml      reldest <- toFilePath `liftM` makeRelativeToCurrentDir dest@@ -63,25 +61,25 @@     when (not (forceOverwrite initOpts) && exists) $         throwString             ("Error: Stack configuration file " <> reldest <>-             " exists, use 'stack solver' to fix the existing config file or \-             \'--force' to overwrite it.")+             " exists, use '--force' to overwrite it.")      dirs <- mapM (resolveDir' . T.unpack) (searchDirs initOpts)-    let noPkgMsg =  "In order to init, you should have an existing .cabal \-                    \file. Please try \"stack new\" instead."-        find  = findCabalDirs (includeSubDirs initOpts)+    let find  = findCabalDirs (includeSubDirs initOpts)         dirs' = if null dirs then [currDir] else dirs     logInfo "Looking for .cabal or package.yaml files to use to init the project."     cabaldirs <- Set.toList . Set.unions <$> mapM find dirs'-    (bundle, dupPkgs)  <- cabalPackagesCheck cabaldirs noPkgMsg Nothing--    (sd, flags, extraDeps, rbundle) <- getDefaultResolver whichCmd dest initOpts-                                                          mresolver bundle--    -- Kind of inefficient, since we've already parsed this value. But-    -- better to reparse in this one case than carry the unneeded data-    -- around everywhere in the codebase.-    resolver <- parseCustomLocation (Just (parent dest)) (void (sdResolver sd))+    (bundle, dupPkgs)  <- cabalPackagesCheck cabaldirs Nothing+    let makeRelDir dir =+            case stripProperPrefix currDir dir of+                Nothing+                    | currDir == dir -> "."+                    | otherwise -> assert False $ toFilePathNoTrailingSep dir+                Just rel -> toFilePathNoTrailingSep rel+        fpToPkgDir fp =+            let absDir = parent fp+            in ResolvedPath (RelFilePath $ T.pack $ makeRelDir absDir) absDir+        pkgDirs = Map.map (fpToPkgDir . fst) bundle+    (snapshotLoc, flags, extraDeps, rbundle) <- getDefaultResolver initOpts mresolver pkgDirs      let ignored = Map.difference bundle rbundle         dupPkgMsg@@ -113,33 +111,30 @@          userMsg = makeUserMsg [dupPkgMsg, missingPkgMsg, extraDepMsg] -        gpds = Map.elems $ fmap snd rbundle-        p = Project+        gpdByDir = Map.fromList [ (parent fp, gpd) | (fp, gpd) <- Map.elems bundle]+        gpds = Map.elems $+          Map.mapMaybe (flip Map.lookup gpdByDir . resolvedAbsolute) rbundle++    deps <- for (Map.toList extraDeps) $ \(n, v) ->+      PLImmutable <$> completePackageLocation (RPLIHackage (PackageIdentifierRevision n v CFILatest) Nothing)++    let p = Project             { projectUserMsg = if userMsg == "" then Nothing else Just userMsg-            , projectPackages = pkgs-            , projectDependencies = map-                (\(n, v) -> PLIndex $ PackageIdentifierRevision (PackageIdentifier n v) CFILatest)-                (Map.toList extraDeps)+            , projectPackages = resolvedRelative <$> Map.elems rbundle+            , projectDependencies = map toRawPL deps             , projectFlags = removeSrcPkgDefaultFlags gpds flags-            , projectResolver = resolver+            , projectResolver = snapshotLoc             , projectCompiler = Nothing             , projectExtraPackageDBs = []+            , projectCurator = Nothing+            , projectDropPackages = mempty             } -        makeRelDir dir =-            case stripProperPrefix currDir dir of-                Nothing-                    | currDir == dir -> "."-                    | otherwise -> assert False $ toFilePathNoTrailingSep dir-                Just rel -> toFilePathNoTrailingSep rel-         makeRel = fmap toFilePath . makeRelativeToCurrentDir -        pkgs = map toPkg $ Map.elems (fmap (parent . fst) rbundle)-        toPkg dir = PLFilePath $ makeRelDir dir         indent t = T.unlines $ fmap ("    " <>) (T.lines t) -    logInfo $ "Initialising configuration using resolver: " <> display (sdResolverName sd)+    logInfo $ "Initialising configuration using resolver: " <> display snapshotLoc     logInfo $ "Total number of user packages considered: "                <> display (Map.size bundle + length dupPkgs) @@ -164,8 +159,7 @@         (if exists then "Overwriting existing configuration file: "          else "Writing configuration to file: ")         <> fromString reldest-    liftIO $ L.writeFile (toFilePath dest)-           $ B.toLazyByteString+    writeBinaryFileAtomic dest            $ renderStackYaml p                (Map.elems $ fmap (makeRelDir . parent . fst) ignored)                (map (makeRelDir . parent) dupPkgs)@@ -240,7 +234,7 @@         [ ("user-message"     , userMsgHelp)         , ("resolver"         , resolverHelp)         , ("packages"         , packageHelp)-        , ("extra-deps"       , "# Dependency packages to be pulled from upstream that are not in the resolver\n# using the same syntax as the packages field.\n# (e.g., acme-missiles-0.3)")+        , ("extra-deps"       , extraDepsHelp)         , ("flags"            , "# Override default flag values for local packages and extra-deps")         , ("extra-package-dbs", "# Extra package databases containing global packages")         ]@@ -280,18 +274,25 @@         , "packages:"         , "- some-directory"         , "- https://example.com/foo/bar/baz-0.0.2.tar.gz"-        , "- location:"-        , "   git: https://github.com/commercialhaskell/stack.git"-        , "   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a"-        , "- location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a"-        , " subdirs:"-        , " - auto-update"-        , " - wai"+        , "  subdirs:"+        , "  - auto-update"+        , "  - wai"         ] +    extraDepsHelp = commentHelp+        [ "Dependency packages to be pulled from upstream that are not in the resolver."+        , "These entries can reference officially published versions as well as"+        , "forks / in-progress versions pinned to a git hash. For example:"+        , ""+        , "extra-deps:"+        , "- acme-missiles-0.3"+        , "- git: https://github.com/commercialhaskell/stack.git"+        , "  commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a"+        , ""+        ]+     footerHelp =-        let major = toCabalVersion-                    $ toMajorVersion $ fromCabalVersion $ C.mkVersion' Meta.version+        let major = toMajorVersion $ C.mkVersion' Meta.version         in commentHelp         [ "Control whether we use the GHC we find on the path"         , "system-ghc: true"@@ -335,184 +336,125 @@ -- | Get the default resolver value getDefaultResolver     :: (HasConfig env, HasGHCVariant env)-    => WhichSolverCmd-    -> Path Abs File   -- ^ stack.yaml-    -> InitOpts+    => InitOpts     -> Maybe AbstractResolver-    -> Map PackageName (Path Abs File, C.GenericPackageDescription)-       -- ^ Src package name: cabal dir, cabal package description+    -> Map PackageName (ResolvedPath Dir)+    -- ^ Src package name: cabal dir     -> RIO env-         ( SnapshotDef+         ( RawSnapshotLocation          , Map PackageName (Map FlagName Bool)          , Map PackageName Version-         , Map PackageName (Path Abs File, C.GenericPackageDescription))+         , Map PackageName (ResolvedPath Dir))        -- ^ ( Resolver        --   , Flags for src packages and extra deps        --   , Extra dependencies        --   , Src packages actually considered)-getDefaultResolver whichCmd stackYaml initOpts mresolver bundle = do-    sd <- maybe selectSnapResolver (makeConcreteResolver (Just root) >=> loadResolver) mresolver-    getWorkingResolverPlan whichCmd stackYaml initOpts bundle sd+getDefaultResolver initOpts mresolver pkgDirs = do+    (candidate, loc) <- case mresolver of+      Nothing -> selectSnapResolver+      Just ar -> do+        sl <- makeConcreteResolver ar+        c <- loadProjectSnapshotCandidate sl NoPrintWarnings False+        return (c, sl)+    getWorkingResolverPlan initOpts pkgDirs candidate loc     where-        root = parent stackYaml         -- TODO support selecting best across regular and custom snapshots         selectSnapResolver = do-            let gpds = Map.elems (fmap snd bundle)             snaps <- fmap getRecommendedSnapshots getSnapshots'-            (s, r) <- selectBestSnapshot (parent stackYaml) gpds snaps+            (c, l, r) <- selectBestSnapshot (Map.elems pkgDirs) snaps             case r of                 BuildPlanCheckFail {} | not (omitPackages initOpts)-                        -> throwM (NoMatchingSnapshot whichCmd snaps)-                _ -> return s+                        -> throwM (NoMatchingSnapshot snaps)+                _ -> return (c, l)  getWorkingResolverPlan     :: (HasConfig env, HasGHCVariant env)-    => WhichSolverCmd-    -> Path Abs File   -- ^ stack.yaml-    -> InitOpts-    -> Map PackageName (Path Abs File, C.GenericPackageDescription)-       -- ^ Src package name: cabal dir, cabal package description-    -> SnapshotDef+    => InitOpts+    -> Map PackageName (ResolvedPath Dir)+    -- ^ Src packages: cabal dir+    -> SnapshotCandidate env+    -> RawSnapshotLocation     -> RIO env-         ( SnapshotDef+         ( RawSnapshotLocation          , Map PackageName (Map FlagName Bool)          , Map PackageName Version-         , Map PackageName (Path Abs File, C.GenericPackageDescription))+         , Map PackageName (ResolvedPath Dir))        -- ^ ( SnapshotDef        --   , Flags for src packages and extra deps        --   , Extra dependencies        --   , Src packages actually considered)-getWorkingResolverPlan whichCmd stackYaml initOpts bundle sd = do-    logInfo $ "Selected resolver: " <> display (sdResolverName sd)-    go bundle+getWorkingResolverPlan initOpts pkgDirs0 snapCandidate snapLoc = do+    logInfo $ "Selected resolver: " <> display snapLoc+    go pkgDirs0     where-        go info = do-            eres <- checkBundleResolver whichCmd stackYaml initOpts info sd+        go pkgDirs = do+            eres <- checkBundleResolver initOpts snapLoc snapCandidate (Map.elems pkgDirs)             -- if some packages failed try again using the rest             case eres of-                Right (f, edeps)-> return (sd, f, edeps, info)+                Right (f, edeps)-> return (snapLoc, f, edeps, pkgDirs)                 Left ignored                     | Map.null available -> do                         logWarn "*** Could not find a working plan for any of \                                  \the user packages.\nProceeding to create a \                                  \config anyway."-                        return (sd, Map.empty, Map.empty, Map.empty)+                        return (snapLoc, Map.empty, Map.empty, Map.empty)                     | otherwise -> do-                        when (Map.size available == Map.size info) $+                        when (Map.size available == Map.size pkgDirs) $                             error "Bug: No packages to ignore"                          if length ignored > 1 then do                           logWarn "*** Ignoring packages:"-                          logWarn $ display $ indent $ showItems ignored+                          logWarn $ display $ indent $ showItems $ map packageNameString ignored                         else                           logWarn $ "*** Ignoring package: "-                                 <> display+                                 <> fromString                                       (case ignored of                                         [] -> error "getWorkingResolverPlan.head"-                                        x:_ -> x)+                                        x:_ -> packageNameString x)                          go available                     where                       indent t   = T.unlines $ fmap ("    " <>) (T.lines t)                       isAvailable k _ = k `notElem` ignored-                      available       = Map.filterWithKey isAvailable info+                      available       = Map.filterWithKey isAvailable pkgDirs  checkBundleResolver     :: (HasConfig env, HasGHCVariant env)-    => WhichSolverCmd-    -> Path Abs File   -- ^ stack.yaml-    -> InitOpts-    -> Map PackageName (Path Abs File, C.GenericPackageDescription)-       -- ^ Src package name: cabal dir, cabal package description-    -> SnapshotDef+    => InitOpts+    -> RawSnapshotLocation+    -> SnapshotCandidate env+    -> [ResolvedPath Dir]+    -- ^ Src package dirs     -> RIO env          (Either [PackageName] ( Map PackageName (Map FlagName Bool)                                , Map PackageName Version))-checkBundleResolver whichCmd stackYaml initOpts bundle sd = do-    result <- checkSnapBuildPlanActual (parent stackYaml) gpds Nothing sd+checkBundleResolver initOpts snapshotLoc snapCandidate pkgDirs = do+    result <- checkSnapBuildPlan pkgDirs Nothing snapCandidate     case result of         BuildPlanCheckOk f -> return $ Right (f, Map.empty)-        BuildPlanCheckPartial f e -> do-            shouldUseSolver <- case (resolver, initOpts) of-                (_, InitOpts { useSolver = True }) -> return True-                (ResolverCompiler _, _) -> do-                    logInfo "Using solver because a compiler resolver was specified."-                    return True-                _ -> return False-            if shouldUseSolver+        BuildPlanCheckPartial _f e -> do -- FIXME:qrilka unused f+            if omitPackages initOpts                 then do                     warnPartial result-                    solve f-                else if omitPackages initOpts-                    then do-                        warnPartial result-                        logWarn "*** Omitting packages with unsatisfied dependencies"-                        return $ Left $ failedUserPkgs e-                    else throwM $ ResolverPartial whichCmd (sdResolverName sd) (show result)+                    logWarn "*** Omitting packages with unsatisfied dependencies"+                    return $ Left $ failedUserPkgs e+                else throwM $ ResolverPartial snapshotLoc (show result)         BuildPlanCheckFail _ e _             | omitPackages initOpts -> do                 logWarn $ "*** Resolver compiler mismatch: "-                           <> display (sdResolverName sd)+                           <> display snapshotLoc                 logWarn $ display $ indent $ T.pack $ show result                 return $ Left $ failedUserPkgs e-            | otherwise -> throwM $ ResolverMismatch whichCmd (sdResolverName sd) (show result)+            | otherwise -> throwM $ ResolverMismatch snapshotLoc (show result)     where-      resolver = sdResolver sd       indent t  = T.unlines $ fmap ("    " <>) (T.lines t)       warnPartial res = do-          logWarn $ "*** Resolver " <> display (sdResolverName sd)+          logWarn $ "*** Resolver " <> display snapshotLoc                       <> " will need external packages: "           logWarn $ display $ indent $ T.pack $ show res        failedUserPkgs e = Map.keys $ Map.unions (Map.elems (fmap deNeededBy e)) -      gpds        = Map.elems (fmap snd bundle)-      solve flags = do-          let cabalDirs      = map parent (Map.elems (fmap fst bundle))-              srcConstraints = mergeConstraints (gpdPackages gpds) flags--          eresult <- solveResolverSpec stackYaml cabalDirs-                                       (sd, srcConstraints, Map.empty)-          case eresult of-              Right (src, ext) ->-                  return $ Right (fmap snd (Map.union src ext), fmap fst ext)-              Left packages-                  | omitPackages initOpts, srcpkgs /= []-> do-                      pkg <- findOneIndependent srcpkgs flags-                      return $ Left [pkg]-                  | otherwise -> throwM (SolverGiveUp giveUpMsg)-                  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-      -- the list of packages when there is conflict in dependencies among this-      -- set of packages.-      findOneIndependent packages flags = do-          platform <- view platformL-          (compiler, _) <- getResolverConstraints Nothing stackYaml sd-          let getGpd pkg = snd (fromMaybe (error "findOneIndependent: getGpd") (Map.lookup pkg bundle))-              getFlags pkg = fromMaybe (error "fromOneIndependent: getFlags") (Map.lookup pkg flags)-              deps pkg = gpdPackageDeps (getGpd pkg) compiler platform-                                        (getFlags pkg)-              allDeps = concatMap (Map.keys . deps) packages-              isIndependent pkg = pkg `notElem` allDeps--              -- prefer to reject packages in deeper directories-              path pkg = fst (fromMaybe (error "findOneIndependent: path") (Map.lookup pkg bundle))-              pathlen = length . FP.splitPath . toFilePath . path-              maxPathlen = maximumBy (compare `on` pathlen)--          return $ maxPathlen (filter isIndependent packages)--      giveUpMsg = concat-          [ "    - Use '--omit-packages to exclude conflicting package(s).\n"-          , "    - Tweak the generated "-          , toFilePath stackDotYaml <> " and then run 'stack solver':\n"-          , "        - Add any missing remote packages.\n"-          , "        - Add extra dependencies to guide solver.\n"-          , "    - Update external packages with 'stack update' and try again.\n"-          ]- getRecommendedSnapshots :: Snapshots -> NonEmpty SnapName getRecommendedSnapshots snapshots =     -- in order - Latest LTS, Latest Nightly, all LTS most recent first@@ -528,8 +470,6 @@ data InitOpts = InitOpts     { searchDirs     :: ![T.Text]     -- ^ List of sub directories to search for .cabal files-    , useSolver      :: Bool-    -- ^ Use solver to determine required external dependencies     , omitPackages   :: Bool     -- ^ Exclude conflicting or incompatible user packages     , forceOverwrite :: Bool@@ -537,3 +477,106 @@     , includeSubDirs :: Bool     -- ^ If True, include all .cabal files found in any sub directories     }++findCabalDirs+  :: HasConfig env+  => Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir))+findCabalDirs recurse dir =+    Set.fromList . map parent+    <$> liftIO (findFiles dir isHpackOrCabal subdirFilter)+  where+    subdirFilter subdir = recurse && not (isIgnored subdir)+    isHpack = (== "package.yaml")     . toFilePath . filename+    isCabal = (".cabal" `isSuffixOf`) . toFilePath+    isHpackOrCabal x = isHpack x || isCabal x++    isIgnored path = "." `isPrefixOf` dirName || dirName `Set.member` ignoredDirs+      where+        dirName = FP.dropTrailingPathSeparator (toFilePath (dirname path))++-- | Special directories that we don't want to traverse for .cabal files+ignoredDirs :: Set FilePath+ignoredDirs = Set.fromList+    [ "dist"+    ]++cabalPackagesCheck+    :: (HasConfig env, HasGHCVariant env)+     => [Path Abs Dir]+     -> Maybe String+     -> RIO env+          ( Map PackageName (Path Abs File, C.GenericPackageDescription)+          , [Path Abs File])+cabalPackagesCheck cabaldirs dupErrMsg = do+    when (null cabaldirs) $ do+      logWarn "We didn't find any local package directories"+      logWarn "You may want to create a package with \"stack new\" instead"+      logWarn "Create an empty project for now"+      logWarn "If this isn't what you want, please delete the generated \"stack.yaml\""++    relpaths <- mapM prettyPath cabaldirs+    logInfo "Using cabal packages:"+    logInfo $ formatGroup relpaths++    packages <- for cabaldirs $ \dir -> do+      (gpdio, _name, cabalfp) <- loadCabalFilePath dir+      gpd <- liftIO $ gpdio YesPrintWarnings+      pure (cabalfp, gpd)++    -- package name cannot be empty or missing otherwise+    -- it will result in cabal solver failure.+    -- stack requires packages name to match the cabal file name+    -- Just the latter check is enough to cover both the cases++    let normalizeString = T.unpack . T.normalize T.NFC . T.pack+        getNameMismatchPkg (fp, gpd)+            | (normalizeString . packageNameString . gpdPackageName) gpd /= (normalizeString . FP.takeBaseName . toFilePath) fp+                = Just fp+            | otherwise = Nothing+        nameMismatchPkgs = mapMaybe getNameMismatchPkg packages++    when (nameMismatchPkgs /= []) $ do+        rels <- mapM prettyPath nameMismatchPkgs+        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"+                <> T.unpack (utf8BuilderToText (formatGroup rels))++    let dupGroups = filter ((> 1) . length)+                            . groupSortOn (gpdPackageName . snd)+        dupAll    = concat $ dupGroups packages++        -- Among duplicates prefer to include the ones in upper level dirs+        pathlen     = length . FP.splitPath . toFilePath . fst+        getmin      = minimumBy (compare `on` pathlen)+        dupSelected = map getmin (dupGroups packages)+        dupIgnored  = dupAll \\ dupSelected+        unique      = packages \\ dupIgnored++    when (dupIgnored /= []) $ do+        dups <- mapM (mapM (prettyPath. fst)) (dupGroups packages)+        logWarn $+            "Following packages have duplicate package names:\n" <>+            mconcat (intersperse "\n" (map formatGroup dups))+        case dupErrMsg of+          Nothing -> logWarn $+                 "Packages with duplicate names will be ignored.\n"+              <> "Packages in upper level directories will be preferred.\n"+          Just msg -> error msg++    return (Map.fromList+            $ map (\(file, gpd) -> (gpdPackageName gpd,(file, gpd))) unique+           , map fst dupIgnored)++formatGroup :: [String] -> Utf8Builder+formatGroup = foldMap (\path -> "- " <> fromString path <> "\n")++prettyPath ::+       (MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t))+    => Path r t+    -> m FilePath+prettyPath path = do+    eres <- liftIO $ try $ makeRelativeToCurrentDir path+    return $ case eres of+        Left (_ :: PathException) -> toFilePath path+        Right res -> toFilePath res
+ src/Stack/Lock.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Stack.Lock+    ( lockCachedWanted+    , LockedLocation(..)+    , Locked(..)+    ) where++import Pantry.Internal.AesonExtended+import Data.ByteString.Builder (byteString)+import qualified Data.List.NonEmpty as NE+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Yaml as Yaml+import Pantry+import Path (addFileExtension, parent)+import Path.IO (doesFileExist)+import Stack.Prelude+import Stack.SourceMap+import Stack.Types.Config+import Stack.Types.SourceMap++data LockedLocation a b = LockedLocation+    { llOriginal :: a+    , llCompleted :: b+    } deriving (Eq, Show)++instance (ToJSON a, ToJSON b) => ToJSON (LockedLocation a b) where+    toJSON ll =+        object [ "original" .= llOriginal ll, "completed" .= llCompleted ll ]++instance ( FromJSON (WithJSONWarnings (Unresolved a))+         , FromJSON (WithJSONWarnings (Unresolved b))+         ) =>+         FromJSON (WithJSONWarnings (Unresolved (LockedLocation a b))) where+    parseJSON =+        withObjectWarnings "LockedLocation" $ \o -> do+            original <- jsonSubWarnings $ o ..: "original"+            completed <- jsonSubWarnings $ o ..: "completed"+            pure $ LockedLocation <$> original <*> completed++-- Special wrapper extracting only 1 RawPackageLocationImmutable+-- serialization should not produce locations with multiple subdirs+-- so we should be OK using just a head element+newtype SingleRPLI = SingleRPLI { unSingleRPLI :: RawPackageLocationImmutable}++instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where+   parseJSON v =+     do+       WithJSONWarnings unresolvedRPLIs ws <- parseJSON v+       let withWarnings x = WithJSONWarnings x ws+       pure $ withWarnings $ SingleRPLI . NE.head <$> unresolvedRPLIs++data Locked = Locked+    { lckSnapshotLocations :: [LockedLocation RawSnapshotLocation SnapshotLocation]+    , lckPkgImmutableLocations :: [LockedLocation RawPackageLocationImmutable PackageLocationImmutable]+    } deriving (Eq, Show)++instance ToJSON Locked where+    toJSON Locked {..} =+        object+            [ "snapshots" .= lckSnapshotLocations+            , "packages" .= lckPkgImmutableLocations+            ]++instance FromJSON (WithJSONWarnings (Unresolved Locked)) where+    parseJSON = withObjectWarnings "Locked" $ \o -> do+      snapshots <- jsonSubWarningsT $ o ..: "snapshots"+      packages <- jsonSubWarningsT $ o ..: "packages"+      let unwrap ll = ll { llOriginal = unSingleRPLI (llOriginal ll) }+      pure $ Locked <$> sequenceA snapshots <*> (map unwrap <$> sequenceA packages)++loadYamlThrow+    :: HasLogFunc env+    => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a+loadYamlThrow parser path = do+    val <- liftIO $ Yaml.decodeFileThrow (toFilePath path)+    case Yaml.parseEither parser val of+        Left err -> throwIO $ Yaml.AesonException err+        Right (WithJSONWarnings res warnings) -> do+            logJSONWarnings (toFilePath path) warnings+            return res++lockCachedWanted ::+       (HasPantryConfig env, HasRunner env)+    => Path Abs File+    -> RawSnapshotLocation+    -> (Map RawPackageLocationImmutable PackageLocationImmutable+        -> WantedCompiler+        -> Map PackageName (Bool -> RIO env DepPackage)+        -> RIO env ( SMWanted, [CompletedPLI]))+    -> RIO env SMWanted+lockCachedWanted stackFile resolver fillWanted = do+    lockFile <- liftIO $ addFileExtension "lock" stackFile+    let getLockExists = doesFileExist lockFile+    lfb <- view lockFileBehaviorL+    readLockFile <-+      case lfb of+        LFBIgnore -> pure False+        LFBReadWrite -> getLockExists+        LFBReadOnly -> getLockExists+        LFBErrorOnWrite -> getLockExists+    locked <-+        if readLockFile+        then do+            logDebug "Using package location completions from a lock file"+            unresolvedLocked <- loadYamlThrow parseJSON lockFile+            resolvePaths (Just $ parent stackFile) unresolvedLocked+        else do+            logDebug "Not reading lock file"+            pure $ Locked [] []+    let toMap :: Ord a => [LockedLocation a b] -> Map a b+        toMap =  Map.fromList . map (\ll -> (llOriginal ll, llCompleted ll))+        slocCache = toMap $ lckSnapshotLocations locked+        pkgLocCache = toMap $ lckPkgImmutableLocations locked+    (snap, slocCompleted, pliCompleted) <-+        loadAndCompleteSnapshotRaw resolver slocCache pkgLocCache+    let compiler = snapshotCompiler snap+        snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap)+    (wanted, prjCompleted) <- fillWanted Map.empty compiler snPkgs+    let lockLocations = map (\(CompletedPLI r c) -> LockedLocation r c)+        differentSnapLocs (CompletedSL raw complete)+          | raw == toRawSL complete = Nothing+          | otherwise = Just $ LockedLocation raw complete+        newLocked = Locked { lckSnapshotLocations = mapMaybe differentSnapLocs slocCompleted+                           , lckPkgImmutableLocations =+                             lockLocations $ pliCompleted <> prjCompleted+                           }+    when (newLocked /= locked) $ do+      case lfb of+        LFBReadWrite ->+          writeBinaryFileAtomic lockFile $+            header <>+            byteString (Yaml.encode newLocked)+        LFBErrorOnWrite -> do+          logError "You indicated that Stack should error out on writing a lock file"+          logError $+            "I just tried to write the following lock file contents to " <>+            fromString (toFilePath lockFile)+          logError $ display $ decodeUtf8With lenientDecode $ Yaml.encode newLocked+          exitFailure+        LFBIgnore -> pure ()+        LFBReadOnly -> pure ()+    pure wanted+  where+    header =+      "# This file was autogenerated by Stack.\n\+      \# You should not edit this file by hand.\n\+      \# For more information, please see the documentation at:\n\+      \#   https://docs.haskellstack.org/en/stable/lock_files\n\n"
src/Stack/Ls.hs view
@@ -10,13 +10,10 @@   ) where  import Control.Exception (Exception, throw)-import Control.Monad.Catch (MonadThrow)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Reader (MonadReader) import Control.Monad (when) import Data.Aeson-import Stack.Prelude-import Stack.Types.Runner+import Data.Array.IArray ((//), elems)+import Stack.Prelude hiding (Snapshot (..)) import qualified Data.Aeson.Types as A import qualified Data.List as L import Data.Text hiding (pack, intercalate)@@ -24,18 +21,22 @@ import qualified Data.Text.IO as T import Data.Typeable (Typeable) import qualified Data.Vector as V-import Network.HTTP.StackClient (httpJSON, getGlobalManager, addRequestHeader, getResponseBody, parseRequest,-        setRequestManager, hAccept)+import Network.HTTP.StackClient (httpJSON, addRequestHeader, getResponseBody, parseRequest, hAccept) import qualified Options.Applicative as OA-import Options.Applicative ((<|>))+import Options.Applicative ((<|>), idm)+import Options.Applicative.Builder.Extra (boolFlags) import Path-import Stack.Runners (withBuildConfig, withBuildConfigDot)-import Stack.Types.Config+import RIO.PrettyPrint (useColorL)+import RIO.PrettyPrint.DefaultStyles (defaultStyles)+import RIO.PrettyPrint.Types (StyleSpec)+import RIO.PrettyPrint.StylesUpdate (StylesUpdate (..), stylesUpdateL) import Stack.Dot+import Stack.Runners import Stack.Options.DotParser (listDepsOptsParser)-import System.Process.PagerEditor (pageText)+import Stack.Types.Config+import System.Console.ANSI.Codes (SGR (Reset), setSGRCode, sgrToCode)+import System.Process.Pager (pageText) import System.Directory (listDirectory)-import System.IO (stderr, hPutStrLn)  data LsView     = Local@@ -50,6 +51,7 @@ data LsCmds     = LsSnapshot SnapshotOpts     | LsDependencies ListDepsOpts+    | LsStyles ListStylesOpts  data SnapshotOpts = SnapshotOpts     { soptViewType :: LsView@@ -57,12 +59,18 @@     , soptNightlySnapView :: Bool     } deriving (Eq, Show, Ord) +data ListStylesOpts = ListStylesOpts+    { coptBasic   :: Bool+    , coptSGR     :: Bool+    , coptExample :: Bool+    } deriving (Eq, Ord, Show)+ newtype LsCmdOpts = LsCmdOpts     { lsView :: LsCmds     }  lsParser :: OA.Parser LsCmdOpts-lsParser = LsCmdOpts <$> OA.hsubparser (lsSnapCmd <> lsDepsCmd)+lsParser = LsCmdOpts <$> OA.hsubparser (lsSnapCmd <> lsDepsCmd <> lsStylesCmd)  lsCmdOptsParser :: OA.Parser LsCmds lsCmdOptsParser = LsSnapshot <$> lsViewSnapCmd@@ -70,6 +78,28 @@ lsDepOptsParser :: OA.Parser LsCmds lsDepOptsParser = LsDependencies <$> listDepsOptsParser +lsStylesOptsParser :: OA.Parser LsCmds+lsStylesOptsParser = LsStyles <$> listStylesOptsParser++listStylesOptsParser :: OA.Parser ListStylesOpts+listStylesOptsParser = ListStylesOpts+    <$> boolFlags False+                  "basic"+                  "a basic report of the styles used. The default is a fuller \+                  \one"+                  idm+    <*> boolFlags True+                  "sgr"+                  "the provision of the equivalent SGR instructions (provided \+                  \by default). Flag ignored for a basic report"+                  idm+    <*> boolFlags True+                  "example"+                  "the provision of an example of the applied style (provided \+                  \by default for colored output). Flag ignored for a basic \+                  \report"+                  idm+ lsViewSnapCmd :: OA.Parser SnapshotOpts lsViewSnapCmd =     SnapshotOpts <$>@@ -94,6 +124,19 @@         "dependencies"         (OA.info lsDepOptsParser (OA.progDesc "View the dependencies")) +lsStylesCmd :: OA.Mod OA.CommandFields LsCmds+lsStylesCmd =+    OA.command+        "stack-colors"+        (OA.info lsStylesOptsParser+                 (OA.progDesc "View stack's output styles"))+    <>+    OA.command+        "stack-colours"+        (OA.info lsStylesOptsParser+                 (OA.progDesc "View stack's output styles (alias for \+                              \'stack-colors')"))+ data Snapshot = Snapshot     { snapId :: Text     , snapTitle :: Text@@ -180,11 +223,9 @@ localSnaptoText :: [String] -> Text localSnaptoText xs = T.intercalate "\n" $ L.map T.pack xs -handleLocal-    :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)-    => LsCmdOpts -> m ()+handleLocal :: LsCmdOpts -> RIO Runner () handleLocal lsOpts = do-    (instRoot :: Path Abs Dir) <- installationRootDeps+    (instRoot :: Path Abs Dir) <- withConfig YesReexec $ withDefaultEnvConfig installationRootDeps     isStdoutTerminal <- view terminalL     let snapRootDir = parent $ parent instRoot     snapData' <- liftIO $ listDirectory $ toFilePath snapRootDir@@ -202,17 +243,15 @@                     L.filter (L.isPrefixOf "night") snapData                 _ -> liftIO $ displayLocalSnapshot isStdoutTerminal snapData         LsDependencies _ -> return ()+        LsStyles _ -> return ()  handleRemote-    :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)-    => LsCmdOpts -> m ()+    :: HasRunner env+    => LsCmdOpts -> RIO env () handleRemote lsOpts = do     req <- liftIO $ parseRequest urlInfo-    mgr <- liftIO getGlobalManager     isStdoutTerminal <- view terminalL-    let req' =-            setRequestManager mgr $-            addRequestHeader hAccept "application/json" req+    let req' = addRequestHeader hAccept "application/json" req     result <- httpJSON req'     let snapData = getResponseBody result     case lsView lsOpts of@@ -228,27 +267,28 @@                     filterSnapshotData snapData Nightly                 _ -> liftIO $ displaySnapshotData isStdoutTerminal snapData         LsDependencies _ -> return ()+        LsStyles _ -> return ()   where     urlInfo = "https://www.stackage.org/snapshots" -lsCmd :: LsCmdOpts -> GlobalOpts -> IO ()-lsCmd lsOpts go =+lsCmd :: LsCmdOpts -> RIO Runner ()+lsCmd lsOpts =     case lsView lsOpts of         LsSnapshot SnapshotOpts {..} ->             case soptViewType of-                Local -> withBuildConfig go (handleLocal lsOpts)-                Remote -> withBuildConfig go (handleRemote lsOpts)-        LsDependencies depOpts -> listDependenciesCmd False depOpts go+                Local -> handleLocal lsOpts+                Remote -> handleRemote lsOpts+        LsDependencies depOpts -> listDependenciesCmd False depOpts+        LsStyles stylesOpts -> withConfig NoReexec $ listStylesCmd stylesOpts  -- | List the dependencies-listDependenciesCmd :: Bool -> ListDepsOpts -> GlobalOpts -> IO ()-listDependenciesCmd deprecated opts go = do+listDependenciesCmd :: Bool -> ListDepsOpts -> RIO Runner ()+listDependenciesCmd deprecated opts = do     when         deprecated-        (hPutStrLn-             stderr+        (logWarn              "DEPRECATED: Use ls dependencies instead. Will be removed in next major version.")-    withBuildConfigDot (listDepsDotOpts opts) go $ listDependencies opts+    listDependencies opts  lsViewLocalCmd :: OA.Mod OA.CommandFields LsView lsViewLocalCmd =@@ -261,3 +301,29 @@     OA.command         "remote"         (OA.info (pure Remote) (OA.progDesc "View remote snapshot"))++-- | List stack's output styles+listStylesCmd :: ListStylesOpts -> RIO Config ()+listStylesCmd opts = do+    lc <- ask+    -- This is the same test as is used in Stack.Types.Runner.withRunner+    let useColor = view useColorL lc+        styles = elems $ defaultStyles // stylesUpdate (view stylesUpdateL lc)+        isComplex = not (coptBasic opts)+        showSGR = isComplex && coptSGR opts+        showExample = isComplex && coptExample opts && useColor+        styleReports = L.map (styleReport showSGR showExample) styles+    liftIO $ T.putStrLn $ T.intercalate (if isComplex then "\n" else ":") styleReports+  where+    styleReport :: Bool -> Bool -> StyleSpec -> Text+    styleReport showSGR showExample (k, sgrs) = k <> "=" <> codes+        <> (if showSGR then sgrsList else mempty)+        <> (if showExample then example else mempty)+      where+        codes = T.intercalate ";" (L.map (fromString . show) $+                    L.concatMap sgrToCode sgrs)+        sgrsList = " [" <> T.intercalate ", " (L.map (fromString . show) sgrs)+                   <> "]"+        example = " " <> ansi <> "Example" <> reset+        ansi = fromString $ setSGRCode sgrs+        reset = fromString $ setSGRCode [Reset]
src/Stack/New.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}  -- | Create new a new project directory populated with a basic working -- project.@@ -19,6 +18,7 @@ import           Stack.Prelude import           Control.Monad.Trans.Writer.Strict import           Control.Monad (void)+import           Data.ByteString.Builder (lazyByteString) import qualified Data.ByteString.Lazy as LB import           Data.Conduit import           Data.List@@ -30,14 +30,14 @@ import qualified Data.Text.Lazy.Encoding as TLE import           Data.Time.Calendar import           Data.Time.Clock-import           Network.HTTP.Download-import           Network.HTTP.StackClient (Request, HttpException, getResponseStatusCode, getResponseBody)+import           Network.HTTP.StackClient (DownloadException (..), Request, HttpException,+                                           getResponseStatusCode, getResponseBody, httpLbs,+                                           parseRequest, parseUrlThrow, redownload, setGithubHeaders) import           Path import           Path.IO import           Stack.Constants import           Stack.Constants.Config import           Stack.Types.Config-import           Stack.Types.PackageName import           Stack.Types.TemplateName import           RIO.Process import qualified Text.Mustache as Mustache@@ -100,7 +100,7 @@         logInfo             (loading <> " template \"" <> display (templateName template) <>              "\" to create project \"" <>-             display (packageNameText project) <>+             fromString (packageNameString project) <>              "\" in " <>              if bare then "the current directory"                      else fromString (toFilePath (dirname absDir)) <>@@ -119,13 +119,13 @@     case templatePath name of         AbsPath absFile -> logIt LocalTemp >> loadLocalFile absFile         UrlPath s -> downloadFromUrl s templateDir-        RelPath relFile ->+        RelPath rawParam relFile ->             catch                 (do f <- loadLocalFile relFile                     logIt LocalTemp                     return f)                 (\(e :: NewException) ->-                      case relRequest relFile of+                      case relRequest rawParam of                         Just req -> downloadTemplate req                                                      (templateDir </> relFile)                         Nothing -> throwM e@@ -143,9 +143,9 @@         if exists             then readFileUtf8 (toFilePath path)             else throwM (FailedToLoadTemplate name (toFilePath path))-    relRequest :: Path Rel File -> Maybe Request-    relRequest rel = do-        rtp <- parseRepoPathWithService defaultRepoService (T.pack (toFilePath rel))+    relRequest :: String -> Maybe Request+    relRequest req = do+        rtp <- parseRepoPathWithService defaultRepoService (T.pack req)         let url = urlFromRepoTemplatePath rtp         parseRequest (T.unpack url)     downloadFromUrl :: String -> Path Abs Dir -> RIO env Text@@ -170,8 +170,6 @@                 logWarn "Using cached local version. It may not be the most recent version though."         else throwM (FailedToDownloadTemplate name exception) -    backupUrlRelPath = $(mkRelFile "downloaded.template.file.hsfiles")- -- | Construct a URL for downloading from a repo. urlFromRepoTemplatePath :: RepoTemplatePath -> Text urlFromRepoTemplatePath (RepoTemplatePath Github user name) =@@ -198,9 +196,9 @@       return $ T.pack . show $ year     let context = M.unions [nonceParams, nameParams, configParams, yearParam]           where-            nameAsVarId = T.replace "-" "_" $ packageNameText project-            nameAsModule = T.filter (/= '-') $ T.toTitle $ packageNameText project-            nameParams = M.fromList [ ("name", packageNameText project)+            nameAsVarId = T.replace "-" "_" $ T.pack $ packageNameString project+            nameAsModule = T.filter (/= '-') $ T.toTitle $ T.pack $ packageNameString project+            nameParams = M.fromList [ ("name", T.pack $ packageNameString project)                                     , ("name-as-varid", nameAsVarId)                                     , ("name-as-module", nameAsModule) ]             configParams = configTemplateParams config@@ -269,11 +267,12 @@     :: MonadIO m     => Map (Path Abs File) LB.ByteString -> m () writeTemplateFiles files =+    liftIO $     forM_         (M.toList files)         (\(fp,bytes) ->               do ensureDir (parent fp)-                 liftIO (LB.writeFile (toFilePath fp) bytes))+                 writeBinaryFileAtomic fp $ lazyByteString bytes)  -- | Run any initialization functions, such as Git. runTemplateInits@@ -301,10 +300,6 @@  -------------------------------------------------------------------------------- -- Defaults---- | The default template name you can use if you don't have one.-defaultTemplateName :: TemplateName-defaultTemplateName = $(mkTemplateName "new-template")  -- | The default service to use to download templates. defaultRepoService :: RepoService
src/Stack/Nix.hs view
@@ -7,9 +7,9 @@  -- | Run commands in a nix-shell module Stack.Nix-  (reexecWithOptionalShell-  ,nixCmdName+  (nixCmdName   ,nixHelpOptName+  ,runShellAndExit   ) where  import           Stack.Prelude@@ -18,60 +18,44 @@ import           Lens.Micro (set) import           Path.IO import qualified Paths_stack as Meta-import           Stack.Config (getInNixShell, getInContainer)+import           Stack.Config (getInContainer, loadBuildConfig) import           Stack.Config.Nix (nixCompiler) import           Stack.Constants (platformVariantEnvVar,inNixShellEnvVar,inContainerEnvVar) import           Stack.Types.Config import           Stack.Types.Docker import           Stack.Types.Nix-import           Stack.Types.Runner-import           Stack.Types.Compiler+import           Stack.Docker (getProjectRoot) import           System.Environment (getArgs,getExecutablePath,lookupEnv) import qualified System.FilePath  as F import           RIO.Process (processContextL, exec) --- | If Nix is enabled, re-runs the currently running OS command in a Nix container.--- Otherwise, runs the inner action.-reexecWithOptionalShell-    :: HasConfig env-    => Maybe (Path Abs Dir)-    -> IO (CompilerVersion 'CVWanted)-    -> IO ()-    -> RIO env ()-reexecWithOptionalShell mprojectRoot getCompilerVersion inner =-  do config <- view configL-     inShell <- getInNixShell-     inContainer <- getInContainer-     isReExec <- view reExecL-     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-    :: HasConfig env-    => Maybe (Path Abs Dir)-    -> IO (CompilerVersion 'CVWanted)-    -> RIO env (String, [String])-    -> RIO env ()-runShellAndExit mprojectRoot getCompilerVersion getCmdArgs = do+runShellAndExit :: RIO Config void+runShellAndExit = do+   inContainer <- getInContainer -- TODO we can probably assert that this is False based on Stack.Runners now+   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    config <- view configL    envOverride <- view processContextL    local (set processContextL envOverride) $ do-     (cmnd,args) <- fmap (escape *** map escape) getCmdArgs+     let cmnd = escape exePath+         args' = map escape args+     projectRoot <- getProjectRoot      mshellFile <--         traverse (resolveFile (fromMaybeProjectRoot mprojectRoot)) $+         traverse (resolveFile projectRoot) $          nixInitFile (configNix config)-     compilerVersion <- liftIO getCompilerVersion-     inContainer <- getInContainer++     -- This will never result in double loading the build config, since:+     --+     -- 1. This function explicitly takes a Config, not a HasConfig+     --+     -- 2. This function ends up exiting before running other code+     -- (thus the void return type)+     compilerVersion <- view wantedCompilerVersionL <$> loadBuildConfig+      ghc <- either throwIO return $ nixCompiler compilerVersion      let pkgsInConfig = nixPackages (configNix config)          pkgs = pkgsInConfig ++ [ghc, "git", "gcc", "gmp"]@@ -101,6 +85,8 @@                               ,"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; "+                               -- overriding default locale so Unicode output using base won't be broken+                              ,"LANG=\"en_US.UTF-8\";"                               ,"} \"\""]]                     -- glibcLocales is necessary on Linux to avoid warnings about GHC being incapable to set the locale.          fullArgs = concat [if pureShell then ["--pure"] else []@@ -109,7 +95,7 @@                                                 F.</> "nix-gc-symlinks" F.</> "gc-root"] else []                            ,map T.unpack (nixShellOptions (configNix config))                            ,nixopts-                           ,["--run", unwords (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@@ -127,10 +113,6 @@                                    ("'\"'\"'"++)                                  else (c:)) "" str                  ++ "'"---- | Fail with friendly error if project root not set.-fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir-fromMaybeProjectRoot = fromMaybe (impureThrow CannotDetermineProjectRoot)  -- | Command-line argument for "nix" nixCmdName :: String
src/Stack/Options/BuildMonoidParser.hs view
@@ -22,7 +22,7 @@     preFetch <*> keepGoing <*> keepTmpFiles <*> forceDirty <*>     tests <*> testOptsParser hideBool <*> benches <*>     benchOptsParser hideBool <*> reconfigure <*> cabalVerbose <*> splitObjs <*> skipComponents <*>-    interleavedOutput+    interleavedOutput <*> ddumpDir   where     hideBool = hide0 /= BuildCmdGlobalOpts     hide =@@ -65,99 +65,102 @@                       \debugging symbols." <>              hideExceptGhci)     libProfiling =-        firstBoolFlags+        firstBoolFlagsFalse             "library-profiling"             "library profiling for TARGETs and all its dependencies"             hide     exeProfiling =-        firstBoolFlags+        firstBoolFlagsFalse             "executable-profiling"             "executable profiling for TARGETs and all its dependencies"             hide     libStripping =-        firstBoolFlags+        firstBoolFlagsTrue             "library-stripping"             "library stripping for TARGETs and all its dependencies"             hide     exeStripping =-        firstBoolFlags+        firstBoolFlagsTrue             "executable-stripping"             "executable stripping for TARGETs and all its dependencies"             hide     haddock =-        firstBoolFlags+        firstBoolFlagsFalse             "haddock"             "generating Haddocks the package(s) in this directory/configuration"             hide     openHaddocks =-        firstBoolFlags+        firstBoolFlagsFalse             "open"             "opening the local Haddock documentation in the browser"             hide     haddockDeps =-        firstBoolFlags "haddock-deps" "building Haddocks for dependencies" hide+        firstBoolFlagsNoDefault+            "haddock-deps"+            "building Haddocks for dependencies (default: true if building Haddocks, false otherwise)"+            hide     haddockInternal =-        firstBoolFlags+        firstBoolFlagsFalse             "haddock-internal"             "building Haddocks for internal modules (like cabal haddock --internal)"             hide     haddockHyperlinkSource =-        firstBoolFlags+        firstBoolFlagsTrue             "haddock-hyperlink-source"             "building hyperlinked source for Haddock (like haddock --hyperlinked-source)"             hide     copyBins =-        firstBoolFlags+        firstBoolFlagsFalse             "copy-bins"             "copying binaries to the local-bin-path (see 'stack path')"             hide     copyCompilerTool =-        firstBoolFlags+        firstBoolFlagsFalse             "copy-compiler-tool"             "copying binaries of targets to compiler-tools-bin (see 'stack path')"             hide     keepGoing =-        firstBoolFlags+        firstBoolFlagsNoDefault             "keep-going"             "continue running after a step fails (default: false for build, true for test/bench)"             hide     keepTmpFiles =-        firstBoolFlags+        firstBoolFlagsFalse             "keep-tmp-files"-            "keep intermediate files and build directories (default: false)"+            "keep intermediate files and build directories"             hide     preFetch =-        firstBoolFlags+        firstBoolFlagsFalse             "prefetch"              "Fetch packages necessary for the build immediately, useful with --dry-run"              hide     forceDirty =-        firstBoolFlags+        firstBoolFlagsFalse             "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+        firstBoolFlagsFalse             "test"             "testing the package(s) in this directory/configuration"             hideExceptGhci     benches =-        firstBoolFlags+        firstBoolFlagsFalse             "bench"             "benchmarking the package(s) in this directory/configuration"             hideExceptGhci     reconfigure =-        firstBoolFlags+        firstBoolFlagsFalse              "reconfigure"              "Perform the configure step even if unnecessary. Useful in some corner cases with custom Setup.hs files"             hide     cabalVerbose =-        firstBoolFlags+        firstBoolFlagsFalse             "cabal-verbose"             "Ask Cabal to be verbose in its output"             hide     splitObjs =-        firstBoolFlags+        firstBoolFlagsFalse             "split-objs"             ("Enable split-objs, to reduce output size (at the cost of build time). " ++ splitObjsWarning)             hide@@ -169,7 +172,13 @@                  help "Skip given component, can be specified multiple times" <>                  hide)))     interleavedOutput =-        firstBoolFlags+        firstBoolFlagsTrue             "interleaved-output"             "Print concurrent GHC output to the console with a prefix for the package name"             hide+    ddumpDir =+        optionalFirst+            (strOption+                (long "ddump-dir" <>+                 help "Specify output ddump-files" <>+                 hide))
src/Stack/Options/BuildParser.hs view
@@ -11,9 +11,6 @@ import           Stack.Options.PackageParser (readFlag) import           Stack.Prelude import           Stack.Types.Config-import           Stack.Types.FlagName-import           Stack.Types.PackageName-import           Stack.Types.Version  -- | Parser for CLI-only build arguments buildOptsParser :: BuildCommand@@ -90,11 +87,9 @@              (metavar "TARGET" <>               completer targetCompleter <>               help ("If none specified, use all local packages. " <>-                    "See https://docs.haskellstack.org/en/v" <>-                    versionString stackMinorVersion <>-                    "/build_command/#target-syntax for details.")))+                    "See https://docs.haskellstack.org/en/stable/build_command/#target-syntax for details."))) -flagsParser :: Parser (Map.Map (Maybe PackageName) (Map.Map FlagName Bool))+flagsParser :: Parser (Map.Map ApplyCLIFlag (Map.Map FlagName Bool)) flagsParser =      Map.unionsWith Map.union <$>      many
src/Stack/Options/CleanParser.hs view
@@ -2,21 +2,23 @@ module Stack.Options.CleanParser where  import           Options.Applicative-import           Stack.Clean                       (CleanOpts (..))+import           Stack.Clean                       (CleanCommand(..), CleanOpts (..)) import           Stack.Prelude import           Stack.Types.PackageName  -- | Command-line parser for the clean command.-cleanOptsParser :: Parser CleanOpts-cleanOptsParser = CleanShallow <$> packages <|> doFullClean+cleanOptsParser :: CleanCommand -> Parser CleanOpts+cleanOptsParser Clean = CleanShallow <$> packages <|> doFullClean   where     packages =         many             (packageNameArgument                  (metavar "PACKAGE" <>-                  help "If none specified, clean all local packages"))+                  help "If none specified, clean all project packages"))     doFullClean =         flag'             CleanFull             (long "full" <>-             help "Delete all work directories (.stack-work by default) in the project")+             help "Delete the project’s stack working directories (.stack-work by default).")++cleanOptsParser Purge = pure CleanFull
src/Stack/Options/Completion.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}  module Stack.Options.Completion@@ -20,18 +19,13 @@ import qualified Distribution.Types.UnqualComponentName as C import           Options.Applicative import           Options.Applicative.Builder.Extra-import           Stack.Config (getLocalPackages)-import           Stack.DefaultColorWhen (defaultColorWhen)+import           Stack.Constants (ghcShowOptionsOutput) import           Stack.Options.GlobalParser (globalOptsFromMonoid)-import           Stack.Runners (loadConfigWithOpts)-import           Stack.Prelude hiding (lift)-import           Stack.Setup+import           Stack.Runners+import           Stack.Prelude import           Stack.Types.Config-import           Stack.Types.FlagName import           Stack.Types.NamedComponent-import           Stack.Types.PackageName-import           System.Process (readProcess)-import           Language.Haskell.TH.Syntax (runIO, lift)+import           Stack.Types.SourceMap  ghcOptsCompleter :: Completer ghcOptsCompleter = mkCompleter $ \inputRaw -> return $@@ -41,10 +35,7 @@         otherArgs = reverse otherArgsReversed      in if null curArg then [] else          map (otherArgs ++) $-         filter (curArg `isPrefixOf`)-                -- Technically, we should be consulting the user's current ghc,-                -- but that would require loading up a BuildConfig.-                $(runIO (readProcess "ghc" ["--show-options"] "") >>= lift . lines)+         filter (curArg `isPrefixOf`) ghcShowOptionsOutput  -- TODO: Ideally this would pay attention to --stack-yaml, may require -- changes to optparse-applicative.@@ -58,46 +49,48 @@         -- If it looks like a flag, skip this more costly completion.         ('-': _) -> return []         _ -> do-            defColorWhen <- liftIO defaultColorWhen-            let go = (globalOptsFromMonoid False defColorWhen mempty)-                    { globalLogLevel = LevelOther "silent" }-            loadConfigWithOpts go $ \lc -> do-              bconfig <- liftIO $ lcLoadBuildConfig lc (globalCompiler go)-              envConfig <- runRIO bconfig (setupEnv Nothing)-              runRIO envConfig (inner input)+            go' <- globalOptsFromMonoid False mempty+            let go = go' { globalLogLevel = LevelOther "silent" }+            withRunnerGlobal go $ withConfig NoReexec $ withDefaultEnvConfig $ inner input  targetCompleter :: Completer-targetCompleter = buildConfigCompleter $ \input ->-      filter (input `isPrefixOf`)-    . concatMap allComponentNames-    . Map.toList-    . lpProject-  <$> getLocalPackages+targetCompleter = buildConfigCompleter $ \input -> do+  packages <- view $ buildConfigL.to (smwProject . bcSMWanted)+  comps <- for packages ppComponents+  pure+    $ filter (input `isPrefixOf`)+    $ concatMap allComponentNames+    $ Map.toList comps   where-    allComponentNames (name, lpv) =-        map (T.unpack . renderPkgComponent . (name,)) (Set.toList (lpvComponents lpv))+    allComponentNames (name, comps) =+        map (T.unpack . renderPkgComponent . (name,)) (Set.toList comps)  flagCompleter :: Completer flagCompleter = buildConfigCompleter $ \input -> do-    lpvs <- fmap lpProject getLocalPackages     bconfig <- view buildConfigL+    gpds <- for (smwProject $ bcSMWanted bconfig) ppGPD     let wildcardFlags             = nubOrd-            $ concatMap (\(name, lpv) ->-                map (\fl -> "*:" ++ flagString name fl) (C.genPackageFlags (lpvGPD lpv)))-            $ Map.toList lpvs+            $ concatMap (\(name, gpd) ->+                map (\fl -> "*:" ++ flagString name fl) (C.genPackageFlags gpd))+            $ Map.toList gpds         normalFlags-            = concatMap (\(name, lpv) ->+            = concatMap (\(name, gpd) ->                 map (\fl -> packageNameString name ++ ":" ++ flagString name fl)-                    (C.genPackageFlags (lpvGPD lpv)))-            $ Map.toList lpvs+                    (C.genPackageFlags gpd))+            $ Map.toList gpds         flagString name fl =             let flname = C.unFlagName $ C.flagName fl              in (if flagEnabled name fl then "-" else "") ++ flname+        prjFlags =+          case configProject (bcConfig bconfig) of+            PCProject (p, _) -> projectFlags p+            PCGlobalProject -> mempty+            PCNoProject _ -> mempty         flagEnabled name fl =             fromMaybe (C.flagDefault fl) $-            Map.lookup (fromCabalFlagName (C.flagName fl)) $-            Map.findWithDefault Map.empty name (bcFlags bconfig)+            Map.lookup (C.flagName fl) $+            Map.findWithDefault Map.empty name prjFlags     return $ filter (input `isPrefixOf`) $         case input of             ('*' : ':' : _) -> wildcardFlags@@ -105,14 +98,15 @@             _ -> normalFlags  projectExeCompleter :: Completer-projectExeCompleter = buildConfigCompleter $ \input ->-      filter (input `isPrefixOf`)-    . nubOrd-    . concatMap-        (\(_, lpv) -> map+projectExeCompleter = buildConfigCompleter $ \input -> do+  packages <- view $ buildConfigL.to (smwProject . bcSMWanted)+  gpds <- Map.traverseWithKey (const ppGPD) packages+  pure+    $ filter (input `isPrefixOf`)+    $ nubOrd+    $ concatMap+        (\gpd -> map           (C.unUnqualComponentName . fst)-          (C.condExecutables (lpvGPD lpv))+          (C.condExecutables gpd)         )-    . Map.toList-    . lpProject-  <$> getLocalPackages+        gpds
src/Stack/Options/ConfigParser.hs view
@@ -2,7 +2,6 @@ module Stack.Options.ConfigParser where  import           Data.Char-import qualified Data.Set                          as Set import           Options.Applicative import           Options.Applicative.Builder.Extra import           Path@@ -20,29 +19,33 @@ -- | Command-line arguments parser for configuration. configOptsParser :: FilePath -> GlobalOptsContext -> Parser ConfigMonoid configOptsParser currentDir hide0 =-    (\stackRoot workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch ghcVariant ghcBuild jobs includes libs overrideGccPath overrideHpack 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-        , configMonoidOverrideHpack = overrideHpack-        , configMonoidSkipMsys = skipMsys-        , configMonoidLocalBinPath = localBin-        , configMonoidModifyCodePage = modifyCodePage-        , configMonoidAllowDifferentUser = allowDifferentUser-        , configMonoidDumpLogs = dumpLogs-        })+    (\stackRoot workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch+        ghcVariant ghcBuild jobs includes libs overrideGccPath overrideHpack+        skipGHCCheck skipMsys localBin modifyCodePage allowDifferentUser+        dumpLogs colorWhen -> 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+            , configMonoidOverrideHpack = overrideHpack+            , configMonoidSkipMsys = skipMsys+            , configMonoidLocalBinPath = localBin+            , configMonoidModifyCodePage = modifyCodePage+            , configMonoidAllowDifferentUser = allowDifferentUser+            , configMonoidDumpLogs = dumpLogs+            , configMonoidColorWhen = colorWhen+            })     <$> optionalFirst (absDirOption             ( long stackRootOptionName             <> metavar (map toUpper stackRootOptionName)@@ -61,11 +64,11 @@     <*> buildOptsMonoidParser hide0     <*> dockerOptsParser True     <*> nixOptsParser True-    <*> firstBoolFlags+    <*> firstBoolFlagsNoDefault             "system-ghc"             "using the system installed GHC (on the PATH) if it is available and its version matches. Disabled by default."             hide-    <*> firstBoolFlags+    <*> firstBoolFlagsTrue             "install-ghc"             "downloading and installing GHC if necessary (can be done manually with stack setup)"             hide@@ -84,20 +87,20 @@            <> help "Number of concurrent jobs to run"            <> hide             ))-    <*> fmap Set.fromList (many ((currentDir FilePath.</>) <$> strOption+    <*> many ((currentDir FilePath.</>) <$> strOption             ( long "extra-include-dirs"            <> metavar "DIR"            <> completer dirCompleter            <> help "Extra directories to check for C header files"            <> hide-            )))-    <*> fmap Set.fromList (many ((currentDir FilePath.</>) <$> strOption+            ))+    <*> many ((currentDir FilePath.</>) <$> strOption             ( long "extra-lib-dirs"            <> metavar "DIR"            <> completer dirCompleter            <> help "Extra directories to check for libraries"            <> hide-            )))+            ))     <*> optionalFirst (absFileOption              ( long "with-gcc"             <> metavar "PATH-TO-GCC"@@ -110,35 +113,48 @@             <> help "Use HPACK executable (overrides bundled Hpack)"             <> hide              ))-    <*> firstBoolFlags+    <*> firstBoolFlagsFalse             "skip-ghc-check"             "skipping the GHC version and architecture check"             hide-    <*> firstBoolFlags+    <*> firstBoolFlagsFalse             "skip-msys"             "skipping the local MSYS installation (Windows only)"             hide-    <*> optionalFirst (strOption+    <*> optionalFirst ((currentDir FilePath.</>) <$> strOption              ( long "local-bin-path"             <> metavar "DIR"             <> completer dirCompleter             <> help "Install binaries to DIR"             <> hide              ))-    <*> firstBoolFlags+    <*> firstBoolFlagsTrue             "modify-code-page"             "setting the codepage to support UTF-8 (Windows only)"             hide-    <*> firstBoolFlags+    <*> firstBoolFlagsNoDefault             "allow-different-user"             ("permission for users other than the owner of the stack root " ++-                "directory to use a stack installation (POSIX only)")+                "directory to use a stack installation (POSIX only) " +++                "(default: true inside Docker, otherwise false)")             hide     <*> fmap toDumpLogs-            (firstBoolFlags+            (firstBoolFlagsNoDefault              "dump-logs"-             "dump the build output logs for local packages to the console"+             "dump the build output logs for local packages to the console (default: dump warning logs)"              hide)+    <*> optionalFirst (option readColorWhen+             ( long "color"+            <> long "colour"+            <> metavar "WHEN"+            <> completeWith ["always", "never", "auto"]+            <> help "Specify when to use color in output; WHEN is 'always', \+                    \'never', or 'auto'. On Windows versions before Windows \+                    \10, for terminals that do not support color codes, the \+                    \default is 'never'; color may work on terminals that \+                    \support color codes"+            <> hide+             ))   where     hide = hideMods (hide0 /= OuterGlobalOpts)     toDumpLogs (First (Just True)) = First (Just DumpAllLogs)
src/Stack/Options/DockerParser.hs view
@@ -1,16 +1,13 @@ {-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.DockerParser where -import           Data.Char import           Data.List                         (intercalate) 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.Prelude import           Stack.Options.Utils import           Stack.Types.Version@@ -21,7 +18,8 @@ dockerOptsParser hide0 =     DockerOptsMonoid     <$> pure (Any False)-    <*> firstBoolFlags dockerCmdName+    <*> firstBoolFlagsNoDefault+                       dockerCmdName                        "using a Docker container. --docker implies 'system-ghc: true'"                        hide     <*> fmap First@@ -34,7 +32,8 @@                                                       metavar "IMAGE" <>                                                       help "Exact Docker image ID (overrides docker-repo)") <|>          pure Nothing)-    <*> firstBoolFlags (dockerOptName dockerRegistryLoginArgName)+    <*> firstBoolFlagsNoDefault+                       (dockerOptName dockerRegistryLoginArgName)                        "registry requires login"                        hide     <*> firstStrOption (long (dockerOptName dockerRegistryUsernameArgName) <>@@ -45,13 +44,16 @@                         hide <>                         metavar "PASSWORD" <>                         help "Docker registry password")-    <*> firstBoolFlags (dockerOptName dockerAutoPullArgName)+    <*> firstBoolFlagsTrue+                       (dockerOptName dockerAutoPullArgName)                        "automatic pulling latest version of image"                        hide-    <*> firstBoolFlags (dockerOptName dockerDetachArgName)+    <*> firstBoolFlagsFalse+                       (dockerOptName dockerDetachArgName)                        "running a detached Docker container"                        hide-    <*> firstBoolFlags (dockerOptName dockerPersistArgName)+    <*> firstBoolFlagsFalse+                       (dockerOptName dockerPersistArgName)                        "not deleting container after it exits"                        hide     <*> firstStrOption (long (dockerOptName dockerContainerNameArgName) <>@@ -69,16 +71,15 @@                            completer dirCompleter <>                            help ("Mount volumes from host in container " ++                                  "(may specify multiple times)")))+    <*> firstStrOption (long (dockerOptName dockerMountModeArgName) <>+                        hide <>+                        metavar "SUFFIX" <>+                        help "Volume mount mode suffix")     <*> 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)             (let specialOpts =                      [ dockerStackExeDownloadVal@@ -92,7 +93,8 @@              help (concat [ "Location of "                           , stackProgName                           , " executable used in container" ])))-    <*> firstBoolFlags (dockerOptName dockerSetUserArgName)+    <*> firstBoolFlagsNoDefault+                       (dockerOptName dockerSetUserArgName)                        "setting user in container to match host"                        hide     <*> pure (IntersectingVersionRange anyVersion)@@ -100,48 +102,3 @@     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
@@ -7,6 +7,7 @@ import           Data.List.Split (splitOn) import qualified Data.Set as Set import qualified Data.Text as T+import           Distribution.Types.PackageName(PackageName, mkPackageName) import           Options.Applicative import           Options.Applicative.Builder.Extra import           Stack.Dot@@ -24,6 +25,7 @@           <*> flagsParser           <*> testTargets           <*> benchTargets+          <*> globalHints   where includeExternal = boolFlags externalDefault                                     "external"                                     "inclusion of external dependencies"@@ -49,10 +51,13 @@         benchTargets = switch (long "bench" <>                                help "Consider dependencies of benchmark components") -        splitNames :: String -> [String]-        splitNames = map (takeWhile (not . isSpace) . dropWhile isSpace) . splitOn ","+        splitNames :: String -> [PackageName]+        splitNames = map (mkPackageName . takeWhile (not . isSpace) . dropWhile isSpace) . splitOn "," --- | Parser for arguments to `stack list-dependencies`.+        globalHints = switch (long "global-hints" <>+                              help "Do not require an install GHC; instead, use a hints file for global packages")++-- | Parser for arguments to `stack ls dependencies`. listDepsOptsParser :: Parser ListDepsOpts listDepsOptsParser = ListDepsOpts                  <$> dotOptsParser True -- Default for --external is True.@@ -66,5 +71,9 @@                  <*> boolFlags False                                 "license"                                 "printing of dependency licenses instead of versions"+                                idm+                 <*> boolFlags False+                                "tree"+                                "printing of dependencies as a tree"                                 idm   where escapeSep sep = T.replace "\\t" "\t" (T.replace "\\n" "\n" sep)
src/Stack/Options/ExecParser.hs view
@@ -39,8 +39,7 @@  -- | Parser for extra options to exec command execOptsExtraParser :: Parser ExecOptsExtra-execOptsExtraParser = eoPlainParser <|>-                      ExecOptsEmbellished+execOptsExtraParser = ExecOptsExtra                          <$> eoEnvSettingsParser                          <*> eoPackagesParser                          <*> eoRtsOptionsParser@@ -68,11 +67,6 @@         ( long "rts-options"         <> help "Explicit RTS options to pass to application"         <> metavar "RTSFLAG"))--    eoPlainParser :: Parser ExecOptsExtra-    eoPlainParser = flag' ExecOptsPlain-                          (long "plain" <>-                           help "Use an unmodified environment (only useful with Docker)")      eoCwdParser :: Parser (Maybe FilePath)     eoCwdParser = optional
+ src/Stack/Options/FreezeParser.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Stack.Options.FreezeParser where++import           Data.Semigroup ((<>))+import           Options.Applicative+import           Stack.Freeze+++-- | Parser for arguments to `stack freeze`+freezeOptsParser :: Parser FreezeOpts+freezeOptsParser =+  FreezeOpts <$> flag FreezeProject FreezeSnapshot+                 ( long "snapshot"+                   <> short 's'+                   <> help "Freeze snapshot definition instead of project's stack.yaml" )
src/Stack/Options/GhciParser.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} module Stack.Options.GhciParser where  import           Options.Applicative@@ -9,7 +10,6 @@ import           Stack.Options.BuildParser         (flagsParser) import           Stack.Options.Completion import           Stack.Prelude-import           Stack.Types.Version  -- | Parser for GHCI options ghciOptsParser :: Parser GhciOpts@@ -19,20 +19,24 @@                         (metavar "TARGET/FILE" <>                          completer (targetCompleter <> fileExtCompleter [".hs", ".lhs"]) <>                          help ("If none specified, use all local packages. " <>-                               "See https://docs.haskellstack.org/en/v" <>-                               versionString stackMinorVersion <>-                               "/build_command/#target-syntax for details. " <>+                               "See https://docs.haskellstack.org/en/stable/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" <>+             <*> ((\x y -> x ++ concat y)+                 <$> flag+                     []+                     ["-Wall", "-Werror"]+                     (long "pedantic" <> help "Turn on -Wall and -Werror")+                 <*> many (argsOption (long "ghci-options" <>                                     metavar "OPTIONS" <>                                     completer ghcOptsCompleter <>-                                    help "Additional options passed to GHCi")))-             <*> many-                     (textOption+                                    help "Additional options passed to GHCi"))+             )+             <*> (concat <$> many+                     (argsOption                           (long "ghc-options" <>                            metavar "OPTIONS" <>                            completer ghcOptsCompleter <>-                           help "Additional options passed to both GHC and GHCi"))+                           help "Additional options passed to both GHC and GHCi")))              <*> flagsParser              <*> optional                      (strOption (long "with-ghc" <>
src/Stack/Options/GlobalParser.hs view
@@ -5,6 +5,7 @@  import           Options.Applicative import           Options.Applicative.Builder.Extra+import           Path.IO (getCurrentDir, resolveDir', resolveFile') import qualified Stack.Docker                      as Docker import           Stack.Init import           Stack.Prelude@@ -14,7 +15,6 @@ import           Stack.Options.Utils import           Stack.Types.Config import           Stack.Types.Docker-import           Stack.Types.Runner  -- | Parser for global command-line options. globalOptsParser :: FilePath -> GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid@@ -23,26 +23,31 @@     optionalFirst (strOption (long Docker.reExecArgName <> hidden <> internal)) <*>     optionalFirst (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*>     (First <$> logLevelOptsParser hide0 defLogLevel) <*>-    firstBoolFlags+    firstBoolFlagsTrue         "time-in-log"         "inclusion of timings in logs, for the purposes of using diff with logs"         hide <*>     configOptsParser currentDir kind <*>     optionalFirst (abstractResolverOptsParser hide0) <*>+    pure (First Nothing) <*> -- resolver root is only set via the script command     optionalFirst (compilerOptsParser hide0) <*>-    firstBoolFlags+    firstBoolFlagsNoDefault         "terminal"         "overriding terminal detection in the case of running in a false terminal"         hide <*>-    optionalFirst (option readColorWhen-        (long "color" <>-         metavar "WHEN" <>-         completeWith ["always", "never", "auto"] <>-         help "Specify when to use color in output; WHEN is 'always', 'never', \-              \or 'auto'. On Windows versions before Windows 10, for terminals \-              \that do not support color codes, the default is 'never'; color \-              \may work on terminals that support color codes" <>-         hide)) <*>+    option readStyles+         (long "stack-colors" <>+          long "stack-colours" <>+          metavar "STYLES" <>+          value mempty <>+          help "Specify stack's output styles; STYLES is a colon-delimited \+               \sequence of key=value, where 'key' is a style name and 'value' \+               \is a semicolon-delimited list of 'ANSI' SGR (Select Graphic \+               \Rendition) control codes (in decimal). Use 'stack ls \+               \stack-colors --basic' to see the current sequence. In shells \+               \where a semicolon is a command separator, enclose STYLES in \+               \quotes." <>+          hide) <*>     optionalFirst (option auto         (long "terminal-width" <>          metavar "INT" <>@@ -55,30 +60,52 @@              completer (fileExtCompleter [".yaml"]) <>              help ("Override project stack.yaml file " <>                    "(overrides any STACK_YAML environment variable)") <>-             hide))+             hide)) <*>+    optionalFirst (option readLockFileBehavior+        (long "lock-file" <>+         help "Specify how to interact with lock files. Default: read/write. If resolver is overridden: read-only" <>+         hide))   where     hide = hideMods hide0     hide0 = kind /= OuterGlobalOpts  -- | Create GlobalOpts from GlobalOptsMonoid.-globalOptsFromMonoid :: Bool -> ColorWhen -> GlobalOptsMonoid -> GlobalOpts-globalOptsFromMonoid defaultTerminal defaultColorWhen GlobalOptsMonoid{..} = GlobalOpts+globalOptsFromMonoid :: MonadIO m => Bool -> GlobalOptsMonoid -> m GlobalOpts+globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = do+  resolver <- for (getFirst globalMonoidResolver) $ \ur -> do+    root <-+      case globalMonoidResolverRoot of+        First Nothing -> getCurrentDir+        First (Just dir) -> resolveDir' dir+    resolvePaths (Just root) ur+  stackYaml <-+    case getFirst globalMonoidStackYaml of+      Nothing -> pure SYLDefault+      Just fp -> SYLOverride <$> resolveFile' fp+  pure GlobalOpts     { globalReExecVersion = getFirst globalMonoidReExecVersion     , globalDockerEntrypoint = getFirst globalMonoidDockerEntrypoint     , globalLogLevel = fromFirst defaultLogLevel globalMonoidLogLevel-    , globalTimeInLog = fromFirst True globalMonoidTimeInLog+    , globalTimeInLog = fromFirstTrue globalMonoidTimeInLog     , globalConfigMonoid = globalMonoidConfigMonoid-    , globalResolver = getFirst globalMonoidResolver+    , globalResolver = resolver     , globalCompiler = getFirst globalMonoidCompiler     , globalTerminal = fromFirst defaultTerminal globalMonoidTerminal-    , globalColorWhen = fromFirst defaultColorWhen globalMonoidColorWhen+    , globalStylesUpdate = globalMonoidStyles     , globalTermWidth = getFirst globalMonoidTermWidth-    , globalStackYaml = maybe SYLDefault SYLOverride $ getFirst globalMonoidStackYaml }+    , globalStackYaml = stackYaml+    , globalLockFileBehavior =+        let defLFB =+              case getFirst globalMonoidResolver of+                Nothing -> LFBReadWrite+                _ -> LFBReadOnly+         in fromFirst defLFB globalMonoidLockFileBehavior+    }  initOptsParser :: Parser InitOpts initOptsParser =     InitOpts <$> searchDirs-             <*> solver <*> omitPackages+             <*> omitPackages              <*> overwrite <*> fmap not ignoreSubDirs   where     searchDirs =@@ -92,5 +119,3 @@                        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/NixParser.hs view
@@ -13,10 +13,12 @@ nixOptsParser :: Bool -> Parser NixOptsMonoid nixOptsParser hide0 = overrideActivation <$>   (NixOptsMonoid-  <$> firstBoolFlags nixCmdName+  <$> firstBoolFlagsNoDefault+                     nixCmdName                      "use of a Nix-shell. Implies 'system-ghc: true'"                      hide-  <*> firstBoolFlags "nix-pure"+  <*> firstBoolFlagsNoDefault+                     "nix-pure"                      "use of a pure Nix-shell. Implies '--nix' and 'system-ghc: true'"                      hide   <*> optionalFirst@@ -45,7 +47,8 @@                metavar "PATH_OPTIONS" <>                help "Additional options to override NIX_PATH parts (notably 'nixpkgs')" <>                hide))-  <*> firstBoolFlags "nix-add-gc-roots"+  <*> firstBoolFlagsFalse+                     "nix-add-gc-roots"                      "addition of packages to the nix GC roots so nix-collect-garbage doesn't remove them"                      hide   )
src/Stack/Options/PackageParser.hs view
@@ -5,27 +5,26 @@ import           Options.Applicative import           Options.Applicative.Types         (readerAsk) import           Stack.Prelude-import           Stack.Types.FlagName-import           Stack.Types.PackageName+import           Stack.Types.Config.Build (ApplyCLIFlag (..))  -- | Parser for package:[-]flag-readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool))+readFlag :: ReadM (Map ApplyCLIFlag (Map FlagName Bool)) readFlag = do     s <- readerAsk     case break (== ':') s of         (pn, ':':mflag) -> do             pn' <--                case parsePackageNameFromString pn of+                case parsePackageName pn of                     Nothing-                        | pn == "*" -> return Nothing+                        | pn == "*" -> return ACFAllProjectPackages                         | otherwise -> readerError $ "Invalid package name: " ++ pn-                    Just x -> return $ Just x+                    Just x -> return $ ACFByName x             let (b, flagS) =                     case mflag of                         '-':x -> (False, x)                         _ -> (True, mflag)             flagN <--                case parseFlagNameFromString flagS of+                case parseFlagName flagS of                     Nothing -> readerError $ "Invalid flag name: " ++ flagS                     Just x -> return x             return $ Map.singleton pn' $ Map.singleton flagN b
src/Stack/Options/ResolverParser.hs view
@@ -7,11 +7,10 @@ import           Options.Applicative.Types         (readerAsk) import           Stack.Options.Utils import           Stack.Prelude-import           Stack.Types.Compiler import           Stack.Types.Resolver  -- | Parser for the resolver-abstractResolverOptsParser :: Bool -> Parser AbstractResolver+abstractResolverOptsParser :: Bool -> Parser (Unresolved AbstractResolver) abstractResolverOptsParser hide =     option readAbstractResolver         (long "resolver" <>@@ -19,7 +18,7 @@          help "Override resolver in project file" <>          hideMods hide) -compilerOptsParser :: Bool -> Parser (CompilerVersion 'CVWanted)+compilerOptsParser :: Bool -> Parser WantedCompiler compilerOptsParser hide =     option readCompilerVersion         (long "compiler" <>@@ -27,9 +26,9 @@          help "Use the specified compiler" <>          hideMods hide) -readCompilerVersion :: ReadM (CompilerVersion 'CVWanted)+readCompilerVersion :: ReadM WantedCompiler readCompilerVersion = do     s <- readerAsk-    case parseCompilerVersion (T.pack s) of-        Nothing -> readerError $ "Failed to parse compiler: " ++ s-        Just x -> return x+    case parseWantedCompiler (T.pack s) of+        Left{} -> readerError $ "Failed to parse compiler: " ++ s+        Right x -> return x
src/Stack/Options/SDistParser.hs view
@@ -8,19 +8,11 @@ import           Stack.Options.HpcReportParser (pvpBoundsOption)  -- | Parser for arguments to `stack sdist` and `stack upload`-sdistOptsParser :: Bool -- ^ Whether to sign by default `stack upload` does, `stack sdist` doesn't-                -> Parser SDistOpts-sdistOptsParser signDefault = SDistOpts <$>+sdistOptsParser :: Parser SDistOpts+sdistOptsParser = SDistOpts <$>   many (strArgument $ metavar "DIR" <> completer dirCompleter) <*>   optional pvpBoundsOption <*>   ignoreCheckSwitch <*>-  (if signDefault-    then not <$> switch (long "no-signature" <> help "Do not sign & upload signatures")-    else switch (long "sign" <> help "Sign & upload signatures")) <*>-  strOption-  (long "sig-server" <> metavar "URL" <> showDefault <>-    value "https://sig.commercialhaskell.org" <>-    help "URL") <*>   buildPackageOption <*>   optional (strOption (long "tar-dir" <> help "If specified, copy all the tar to this dir"))   where
src/Stack/Options/ScriptParser.hs view
@@ -12,6 +12,7 @@   , soArgs :: ![String]   , soCompile :: !ScriptExecute   , soGhcOptions :: ![String]+  , soScriptExtraDeps :: ![PackageIdentifierRevision]   }   deriving Show @@ -40,3 +41,9 @@             metavar "OPTIONS" <>             completer ghcOptsCompleter <>             help "Additional options passed to GHC"))+    <*> many (option extraDepRead+          (long "extra-dep" <>+            metavar "PACKAGE-VERSION" <>+            help "Extra dependencies to be added to the snapshot"))+  where+    extraDepRead = eitherReader $ mapLeft show . parsePackageIdentifierRevision . fromString
− src/Stack/Options/SolverParser.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Stack.Options.SolverParser where--import           Options.Applicative-import           Options.Applicative.Builder.Extra-import           Stack.Prelude---- | 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
@@ -13,27 +13,32 @@ testOptsParser :: Bool -> Parser TestOptsMonoid testOptsParser hide0 =     TestOptsMonoid-        <$> firstBoolFlags+        <$> firstBoolFlagsTrue                 "rerun-tests"                 "running already successful tests"                 hide         <*> fmap-                (fromMaybe [])-                (optional+                concat+                (many                     (argsOption                         (long "test-arguments" <>                          long "ta" <>                          metavar "TEST_ARGS" <>                          help "Arguments passed in to the test suite program" <>                          hide)))-        <*> optionalFirst+        <*> optionalFirstFalse                 (flag' True                     (long "coverage" <>                      help "Generate a code coverage report" <>                      hide))-        <*> optionalFirst+        <*> optionalFirstFalse                 (flag' True                     (long "no-run-tests" <>                      help "Disable running of tests. (Tests will still be built.)" <>+                     hide))+        <*> optionalFirst+                (option (fmap Just auto)+                    (long "test-suite-timeout" <>+                     help "Maximum test suite run time in seconds." <>                      hide))    where hide = hideMods hide0
src/Stack/Package.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}@@ -8,18 +7,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-}  -- | Dealing with Cabal.  module Stack.Package-  (readPackageDir-  ,readPackageUnresolvedDir-  ,readPackageUnresolvedIndex-  ,readPackageDescriptionDir-  ,readDotBuildinfo+  (readDotBuildinfo   ,resolvePackage   ,packageFromPackageDescription   ,Package(..)@@ -31,21 +24,15 @@   ,PackageException (..)   ,resolvePackageDescription   ,packageDependencies-  ,cabalFilePackageId-  ,gpdPackageIdentifier-  ,gpdPackageName-  ,gpdVersion)-  where+  ,applyForceCustomBuild+  ) where -import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy.Char8 as CL8-import           Data.List (isPrefixOf, unzip)+import qualified Data.ByteString.Char8 as B8+import           Data.List (find, isPrefixOf, unzip) import           Data.Maybe (maybe) import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TLE import           Distribution.Compiler import           Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as Cabal@@ -54,8 +41,6 @@ import qualified Distribution.PackageDescription as D import           Distribution.PackageDescription hiding (FlagName) import           Distribution.PackageDescription.Parsec-import qualified Distribution.PackageDescription.Parsec as D-import           Distribution.Parsec.Common (PWarning (..), showPos) import           Distribution.Simple.Glob (matchDirFileGlob) import           Distribution.System (OS (..), Arch, Platform (..)) import qualified Distribution.Text as D@@ -65,43 +50,33 @@ import qualified Distribution.Types.LegacyExeDependency as Cabal import           Distribution.Types.MungedPackageName import qualified Distribution.Types.UnqualComponentName as Cabal-import qualified Distribution.Types.Version as Cabal import qualified Distribution.Verbosity as D-import           Lens.Micro (lens)-import qualified Hpack-import qualified Hpack.Config as Hpack+import           Distribution.Version (mkVersion, orLaterVersion, anyVersion)+import qualified HiFileParser as Iface import           Path as FL import           Path.Extra-import           Path.Find import           Path.IO hiding (findFiles) import           Stack.Build.Installed import           Stack.Constants import           Stack.Constants.Config-import           Stack.Fetch (loadFromIndex)-import           Stack.PackageIndex (HasCabalLoader (..)) import           Stack.Prelude hiding (Display (..))-import           Stack.PrettyPrint-import           Stack.Types.Build-import           Stack.Types.BuildPlan (ExeName (..)) import           Stack.Types.Compiler import           Stack.Types.Config-import           Stack.Types.FlagName import           Stack.Types.GhcPkgId import           Stack.Types.NamedComponent import           Stack.Types.Package-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Runner import           Stack.Types.Version import qualified System.Directory as D import           System.FilePath (replaceExtension) import qualified System.FilePath as FilePath import           System.IO.Error import           RIO.Process+import           RIO.PrettyPrint+import qualified RIO.PrettyPrint as PP (Style (Module))  data Ctx = Ctx { ctxFile :: !(Path Abs File)                , ctxDistDir :: !(Path Abs Dir)-               , ctxEnvConfig :: !EnvConfig+               , ctxBuildConfig :: !BuildConfig                }  instance HasPlatform Ctx@@ -110,124 +85,18 @@     logFuncL = configL.logFuncL instance HasRunner Ctx where     runnerL = configL.runnerL+instance HasStylesUpdate Ctx where+  stylesUpdateL = runnerL.stylesUpdateL+instance HasTerm Ctx where+  useColorL = runnerL.useColorL+  termWidthL = runnerL.termWidthL instance HasConfig Ctx-instance HasCabalLoader Ctx where-    cabalLoaderL = configL.cabalLoaderL+instance HasPantryConfig Ctx where+    pantryConfigL = configL.pantryConfigL instance HasProcessContext Ctx where     processContextL = configL.processContextL-instance HasBuildConfig Ctx-instance HasEnvConfig Ctx where-    envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y })---- | A helper function that performs the basic character encoding--- necessary.-rawParseGPD-  :: MonadThrow m-  => Either PackageIdentifierRevision (Path Abs File)-  -> BS.ByteString-  -> m ([PWarning], GenericPackageDescription)-rawParseGPD key bs =-    case eres of-      Left (mversion, errs) -> throwM $ PackageInvalidCabalFile key-        (fromCabalVersion <$> mversion)-        errs-        warnings-      Right gpkg -> return (warnings, gpkg)-  where-    (warnings, eres) = runParseResult $ parseGenericPackageDescription bs---- | Read the raw, unresolved package information from a file.-readPackageUnresolvedDir-  :: forall env. HasConfig env-  => Path Abs Dir -- ^ directory holding the cabal file-  -> Bool -- ^ print warnings?-  -> RIO env (GenericPackageDescription, Path Abs File)-readPackageUnresolvedDir dir printWarnings = do-  ref <- view $ runnerL.to runnerParsedCabalFiles-  (_, m) <- readIORef ref-  case M.lookup dir m of-    Just x -> return x-    Nothing -> do-      cabalfp <- findOrGenerateCabalFile dir-      bs <- liftIO $ BS.readFile $ toFilePath cabalfp-      (warnings, gpd) <- rawParseGPD (Right cabalfp) bs-      when printWarnings-        $ mapM_ (prettyWarnL . toPretty (toFilePath cabalfp)) warnings-      checkCabalFileName (gpdPackageName gpd) cabalfp-      let ret = (gpd, cabalfp)-      atomicModifyIORef' ref $ \(m1, m2) ->-        ((m1, M.insert dir ret m2), ret)-  where-    toPretty :: String -> PWarning -> [Doc AnsiAnn]-    toPretty src (PWarning _type pos msg) =-      [ flow "Cabal file warning in"-      , fromString src <> "@"-      , fromString (showPos pos) <> ":"-      , flow msg-      ]--    -- | Check if the given name in the @Package@ matches the name of the .cabal file-    checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m ()-    checkCabalFileName name cabalfp = do-        -- Previously, we just use parsePackageNameFromFilePath. However, that can-        -- lead to confusing error messages. See:-        -- https://github.com/commercialhaskell/stack/issues/895-        let expected = packageNameString name ++ ".cabal"-        when (expected /= toFilePath (filename cabalfp))-            $ throwM $ MismatchedCabalName cabalfp name--gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier-gpdPackageIdentifier = fromCabalPackageIdentifier . D.package . D.packageDescription--gpdPackageName :: GenericPackageDescription -> PackageName-gpdPackageName = packageIdentifierName . gpdPackageIdentifier--gpdVersion :: GenericPackageDescription -> Version-gpdVersion = packageIdentifierVersion . gpdPackageIdentifier---- | Read the 'GenericPackageDescription' from the given--- 'PackageIdentifierRevision'.-readPackageUnresolvedIndex-  :: forall env. HasCabalLoader env-  => PackageIdentifierRevision-  -> RIO env GenericPackageDescription-readPackageUnresolvedIndex pir@(PackageIdentifierRevision pi' _) = do-  ref <- view $ runnerL.to runnerParsedCabalFiles-  (m, _) <- readIORef ref-  case M.lookup pir m of-    Just gpd -> return gpd-    Nothing -> do-      bs <- loadFromIndex pir-      (_warnings, gpd) <- rawParseGPD (Left pir) bs-      let foundPI =-              fromCabalPackageIdentifier-            $ D.package-            $ D.packageDescription gpd-      unless (pi' == foundPI) $ throwM $ MismatchedCabalIdentifier pir foundPI-      atomicModifyIORef' ref $ \(m1, m2) ->-        ((M.insert pir gpd m1, m2), gpd)---- | Reads and exposes the package information-readPackageDir-  :: forall env. HasConfig env-  => PackageConfig-  -> Path Abs Dir-  -> Bool -- ^ print warnings from cabal file parsing?-  -> RIO env (Package, Path Abs File)-readPackageDir packageConfig dir printWarnings =-  first (resolvePackage packageConfig) <$> readPackageUnresolvedDir dir printWarnings---- | Get 'GenericPackageDescription' and 'PackageDescription' reading info--- from given directory.-readPackageDescriptionDir-  :: forall env. HasConfig env-  => PackageConfig-  -> Path Abs Dir-  -> Bool -- ^ print warnings?-  -> RIO env (GenericPackageDescription, PackageDescriptionPair)-readPackageDescriptionDir config pkgDir printWarnings = do-    (gdesc, _) <- readPackageUnresolvedDir pkgDir printWarnings-    return (gdesc, resolvePackageDescription config gdesc)+instance HasBuildConfig Ctx where+    buildConfigL = lens ctxBuildConfig (\x y -> x { ctxBuildConfig = y })  -- | Read @<package>.buildinfo@ ancillary files produced by some Setup.hs hooks. -- The file includes Cabal file syntax to be merged into the package description@@ -259,15 +128,16 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkgNoMod pkg) =     Package     { packageName = name-    , packageVersion = fromCabalVersion (pkgVersion pkgId)+    , packageVersion = pkgVersion pkgId     , packageLicense = licenseRaw pkg     , packageDeps = deps     , packageFiles = pkgFiles     , packageUnknownTools = unknownTools     , packageGhcOptions = packageConfigGhcOptions packageConfig+    , packageCabalConfigOpts = packageConfigCabalConfigOpts packageConfig     , packageFlags = packageConfigFlags packageConfig     , packageDefaultFlags = M.fromList-      [(fromCabalFlagName (flagName flag), flagDefault flag) | flag <- pkgFlags]+      [(flagName flag, flagDefault flag) | flag <- pkgFlags]     , packageAllDeps = S.fromList (M.keys deps)     , packageLibraries =         let mlib = do@@ -297,13 +167,14 @@     -- This is an action used to collect info needed for "stack ghci".     -- This info isn't usually needed, so computation of it is deferred.     , packageOpts = GetPackageOpts $-      \sourceMap installedMap omitPkgs addPkgs cabalfp ->+      \installMap installedMap omitPkgs addPkgs cabalfp ->            do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp               let internals = S.toList $ internalLibComponents $ M.keysSet componentsModules-              excludedInternals <- mapM parsePackageName internals-              mungedInternals <- mapM (parsePackageName . toInternalPackageMungedName) internals+              excludedInternals <- mapM (parsePackageNameThrowing . T.unpack) internals+              mungedInternals <- mapM (parsePackageNameThrowing . T.unpack .+                                       toInternalPackageMungedName) internals               componentsOpts <--                  generatePkgDescOpts sourceMap installedMap+                  generatePkgDescOpts installMap installedMap                   (excludedInternals ++ omitPkgs) (mungedInternals ++ addPkgs)                   cabalfp pkg componentFiles               return (componentsModules,componentFiles,componentsOpts)@@ -313,6 +184,7 @@           (library pkg)     , packageBuildType = buildType pkg     , packageSetupDeps = msetupDeps+    , packageCabalSpec = either orLaterVersion id $ specVersionRaw pkg     }   where     extraLibNames = S.union subLibNames foreignLibNames@@ -338,31 +210,31 @@     -- constitute the package. This is primarily used for dirtiness     -- checking during build, as well as use by "stack ghci"     pkgFiles = GetPackageFiles $-        \cabalfp -> debugBracket ("getPackageFiles" <+> display cabalfp) $ do+        \cabalfp -> debugBracket ("getPackageFiles" <+> pretty cabalfp) $ do              let pkgDir = parent cabalfp              distDir <- distDirFromDir pkgDir-             env <- view envConfigL+             bc <- view buildConfigL              (componentModules,componentFiles,dataFiles',warnings) <-                  runRIO-                     (Ctx cabalfp distDir env)+                     (Ctx cabalfp distDir bc)                      (packageDescModulesAndFiles pkg)              setupFiles <-                  if buildType pkg == Custom                  then do-                     let setupHsPath = pkgDir </> $(mkRelFile "Setup.hs")-                         setupLhsPath = pkgDir </> $(mkRelFile "Setup.lhs")+                     let setupHsPath = pkgDir </> relFileSetupHs+                         setupLhsPath = pkgDir </> relFileSetupLhs                      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)+                 let hpackPath = pkgDir </> relFileHpackPackageConfig                  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)+    name = pkgName pkgId      (unknownTools, knownTools) = packageDescTools pkg @@ -387,36 +259,36 @@      -- Is the package dependency mentioned here me: either the package     -- name itself, or the name of one of the sub libraries-    isMe name' = name' == name || packageNameText name' `S.member` extraLibNames+    isMe name' = name' == name || fromString (packageNameString name') `S.member` extraLibNames  -- | Generate GHC options for the package's components, and a list of -- options which apply generally to the package, not one specific -- component. generatePkgDescOpts     :: (HasEnvConfig env, MonadThrow m, MonadReader env m, MonadIO m)-    => SourceMap+    => InstallMap     -> InstalledMap     -> [PackageName] -- ^ Packages to omit from the "-package" / "-package-id" flags     -> [PackageName] -- ^ Packages to add to the "-package" flags     -> Path Abs File     -> PackageDescription-    -> Map NamedComponent (Set DotCabalPath)+    -> Map NamedComponent [DotCabalPath]     -> m (Map NamedComponent BuildInfoOpts)-generatePkgDescOpts sourceMap installedMap omitPkgs addPkgs cabalfp pkg componentPaths = do+generatePkgDescOpts installMap installedMap omitPkgs addPkgs cabalfp pkg componentPaths = do     config <- view configL     cabalVer <- view cabalVersionL     distDir <- distDirFromDir cabalDir     let generate namedComponent binfo =             ( namedComponent             , generateBuildInfoOpts BioInput-                { biSourceMap = sourceMap+                { biInstallMap = installMap                 , biInstalledMap = installedMap                 , biCabalDir = cabalDir                 , biDistDir = distDir                 , biOmitPackages = omitPkgs                 , biAddPackages = addPkgs                 , biBuildInfo = binfo-                , biDotCabalPaths = fromMaybe mempty (M.lookup namedComponent componentPaths)+                , biDotCabalPaths = fromMaybe [] (M.lookup namedComponent componentPaths)                 , biConfigLibDirs = configExtraLibDirs config                 , biConfigIncludeDirs = configExtraIncludeDirs config                 , biComponentName = namedComponent@@ -459,16 +331,16 @@  -- | Input to 'generateBuildInfoOpts' data BioInput = BioInput-    { biSourceMap :: !SourceMap+    { biInstallMap :: !InstallMap     , biInstalledMap :: !InstalledMap     , biCabalDir :: !(Path Abs Dir)     , biDistDir :: !(Path Abs Dir)     , biOmitPackages :: ![PackageName]     , biAddPackages :: ![PackageName]     , biBuildInfo :: !BuildInfo-    , biDotCabalPaths :: !(Set DotCabalPath)-    , biConfigLibDirs :: !(Set FilePath)-    , biConfigIncludeDirs :: !(Set FilePath)+    , biDotCabalPaths :: ![DotCabalPath]+    , biConfigLibDirs :: ![FilePath]+    , biConfigIncludeDirs :: ![FilePath]     , biComponentName :: !NamedComponent     , biCabalVersion :: !Version     }@@ -490,14 +362,15 @@         , bioOneWordOpts = nubOrd $ concat             [extOpts, srcOpts, includeOpts, libOpts, fworks, cObjectFiles]         , bioPackageFlags = deps-        , bioCabalMacros = componentAutogen </> $(mkRelFile "cabal_macros.h")+        , bioCabalMacros = componentAutogen </> relFileCabalMacrosH         }   where     cObjectFiles =         mapMaybe (fmap toFilePath .                   makeObjectFilePathFromC biCabalDir biComponentName biDistDir)                  cfiles-    cfiles = mapMaybe dotCabalCFilePath (S.toList biDotCabalPaths)+    cfiles = mapMaybe dotCabalCFilePath biDotCabalPaths+    installVersion = snd     -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ...     deps =         concat@@ -505,14 +378,13 @@                 Just (_, Stack.Types.Package.Library _ident ipid _) -> ["-package-id=" <> ghcPkgIdString ipid]                 _ -> ["-package=" <> packageNameString name <>                  maybe "" -- This empty case applies to e.g. base.-                     ((("-" <>) . versionString) . piiVersion)-                     (M.lookup name biSourceMap)]+                     ((("-" <>) . versionString) . installVersion)+                     (M.lookup name biInstallMap)]             | name <- pkgs]     pkgs =         biAddPackages ++         [ name-        | Dependency cname _ <- targetBuildDepends biBuildInfo-        , let name = fromCabalPackageName cname+        | Dependency name _ <- targetBuildDepends biBuildInfo         , name `notElem` biOmitPackages]     ghcOpts = concatMap snd . filter (isGhc . fst) $ options biBuildInfo       where@@ -536,8 +408,7 @@     toIncludeDir "." = Just biCabalDir     toIncludeDir relDir = concatAndColapseAbsDir biCabalDir relDir     includeOpts =-        map ("-I" <>) (configExtraIncludeDirs <> pkgIncludeOpts)-    configExtraIncludeDirs = S.toList biConfigIncludeDirs+        map ("-I" <>) (biConfigIncludeDirs <> pkgIncludeOpts)     pkgIncludeOpts =         [ toFilePathNoTrailingSep absDir         | dir <- includeDirs biBuildInfo@@ -545,8 +416,7 @@         ]     libOpts =         map ("-l" <>) (extraLibs biBuildInfo) <>-        map ("-L" <>) (configExtraLibDirs <> pkgLibDirs)-    configExtraLibDirs = S.toList biConfigLibDirs+        map ("-L" <>) (biConfigLibDirs <> pkgLibDirs)     pkgLibDirs =         [ toFilePathNoTrailingSep absDir         | dir <- extraLibDirs biBuildInfo@@ -600,18 +470,18 @@ -- | Make the global autogen dir if Cabal version is new enough. packageAutogenDir :: Version -> Path Abs Dir -> Maybe (Path Abs Dir) packageAutogenDir cabalVer distDir-    | cabalVer < $(mkVersion "2.0") = Nothing-    | otherwise = Just $ buildDir distDir </> $(mkRelDir "global-autogen")+    | cabalVer < mkVersion [2, 0] = Nothing+    | otherwise = Just $ buildDir distDir </> relDirGlobalAutogen  -- | Make the autogen dir. componentAutogenDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir componentAutogenDir cabalVer component distDir =-    componentBuildDir cabalVer component distDir </> $(mkRelDir "autogen")+    componentBuildDir cabalVer component distDir </> relDirAutogen  -- | See 'Distribution.Simple.LocalBuildInfo.componentBuildDir' componentBuildDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir componentBuildDir cabalVer component distDir-    | cabalVer < $(mkVersion "2.0") = buildDir distDir+    | cabalVer < mkVersion [2, 0] = buildDir distDir     | otherwise =         case component of             CLib -> buildDir distDir@@ -636,7 +506,7 @@ -- | Make the build dir. Note that Cabal >= 2.0 uses the -- 'componentBuildDir' above for some things. buildDir :: Path Abs Dir -> Path Abs Dir-buildDir distDir = distDir </> $(mkRelDir "build")+buildDir distDir = distDir </> relDirBuild  -- NOTE: don't export this, only use it for valid paths based on -- component names.@@ -664,7 +534,7 @@   maybe [] setupDepends (setupBuildInfo pkg)   where     pkg-      | getGhcVersion (packageConfigCompilerVersion pkgConfig) >= $(mkVersion "8.0") = pkg'+      | getGhcVersion (packageConfigCompilerVersion pkgConfig) >= mkVersion [8, 0] = pkg'       -- Set all components to buildable. Only need to worry about       -- library, exe, test, and bench, since others didn't exist in       -- older Cabal versions@@ -716,7 +586,7 @@         go2 (Cabal.ExeDependency pkg _name range)           | pkg `S.member` preInstalledPackages = Nothing           | otherwise = Just-              ( fromCabalPackageName pkg+              ( pkg               , DepValue                   { dvVersionRange = range                   , dvType = AsBuildTool@@ -771,7 +641,7 @@ -- | Get all files referenced by the package. packageDescModulesAndFiles     :: PackageDescription-    -> RIO Ctx (Map NamedComponent (Map ModuleName (Path Abs File)), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning])+    -> RIO Ctx (Map NamedComponent (Map ModuleName (Path Abs File)), Map NamedComponent [DotCabalPath], Set (Path Abs File), [PackageWarning]) packageDescModulesAndFiles pkg = do     (libraryMods,libDotCabalFiles,libWarnings) <-         maybe@@ -822,7 +692,7 @@  -- | Resolve globbing of files (e.g. data files) to absolute paths. resolveGlobFiles-  :: Cabal.Version -- ^ cabal file version+  :: Version -- ^ cabal file version   -> [String]   -> RIO Ctx (Set (Path Abs File)) resolveGlobFiles cabalFileVersion =@@ -848,9 +718,9 @@                       then do                           prettyWarnL                               [ flow "Wildcard does not match any files:"-                              , styleFile $ fromString glob+                              , style File $ fromString glob                               , line <> flow "in directory:"-                              , styleDir $ fromString dir+                              , style Dir $ fromString dir                               ]                           return []                       else throwIO e)@@ -859,7 +729,7 @@ benchmarkFiles     :: NamedComponent     -> Benchmark-    -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning])+    -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning]) benchmarkFiles component bench = do     resolveComponentFiles component build names   where@@ -875,7 +745,7 @@ testFiles     :: NamedComponent     -> TestSuite-    -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning])+    -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning]) testFiles component test = do     resolveComponentFiles component build names   where@@ -892,7 +762,7 @@ executableFiles     :: NamedComponent     -> Executable-    -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning])+    -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning]) executableFiles component exe = do     resolveComponentFiles component build names   where@@ -905,7 +775,7 @@ libraryFiles     :: NamedComponent     -> Library-    -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning])+    -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning]) libraryFiles component lib = do     resolveComponentFiles component build names   where@@ -919,29 +789,35 @@     :: NamedComponent     -> BuildInfo     -> [DotCabalDescriptor]-    -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning])+    -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning]) resolveComponentFiles component build names = do     dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)     dir <- asks (parent . ctxFile)     (modules,files,warnings) <-         resolveFilesAndDeps             component-            (dirs ++ [dir])+            (if null dirs then [dir] else dirs)             names-            haskellModuleExts     cfiles <- buildOtherSources build     return (modules, files <> cfiles, warnings)  -- | Get all C sources and extra source files in a build.-buildOtherSources :: BuildInfo -> RIO Ctx (Set DotCabalPath)-buildOtherSources build =-    do csources <- liftM-                       (S.map DotCabalCFilePath . S.fromList)-                       (mapMaybeM resolveFileOrWarn (cSources build))-       jsources <- liftM-                       (S.map DotCabalFilePath . S.fromList)-                       (mapMaybeM resolveFileOrWarn (targetJsSources build))-       return (csources <> jsources)+buildOtherSources :: BuildInfo -> RIO Ctx [DotCabalPath]+buildOtherSources build = do+    cwd <- liftIO getCurrentDir+    dir <- asks (parent . ctxFile)+    file <- asks ctxFile+    let resolveDirFiles files toCabalPath =+            forMaybeM files $ \fp -> do+                result <- resolveDirFile dir fp+                case result of+                    Nothing -> do+                        warnMissingFile "File" cwd fp file+                        return Nothing+                    Just p -> return $ Just (toCabalPath p)+    csources <- resolveDirFiles (cSources build) DotCabalCFilePath+    jsources <- resolveDirFiles (targetJsSources build) DotCabalFilePath+    return (csources <> jsources)  -- | Get the target's JS sources. targetJsSources :: BuildInfo -> [FilePath]@@ -1050,17 +926,17 @@ flagMap :: [Flag] -> Map FlagName Bool flagMap = M.fromList . map pair   where pair :: Flag -> (FlagName, Bool)-        pair (MkFlag (fromCabalFlagName -> name) _desc def _manual) = (name,def)+        pair = flagName &&& flagDefault  data ResolveConditions = ResolveConditions     { rcFlags :: Map FlagName Bool-    , rcCompilerVersion :: CompilerVersion 'CVActual+    , rcCompilerVersion :: ActualCompiler     , rcOS :: OS     , rcArch :: Arch     }  -- | Generic a @ResolveConditions@ using sensible defaults.-mkResolveConditions :: CompilerVersion 'CVActual -- ^ Compiler version+mkResolveConditions :: ActualCompiler -- ^ Compiler version                     -> Platform -- ^ installation target platform                     -> Map FlagName Bool -- ^ enabled flags                     -> ResolveConditions@@ -1099,21 +975,21 @@                     OS os -> os == rcOS rc                     Arch arch -> arch == rcArch rc                     Flag flag ->-                      fromMaybe False $ M.lookup (fromCabalFlagName flag) (rcFlags rc)+                      fromMaybe False $ M.lookup flag (rcFlags rc)                       -- NOTE:  ^^^^^ This should never happen, as all flags                       -- which are used must be declared. Defaulting to                       -- False.                     Impl flavor range ->                       case (flavor, rcCompilerVersion rc) of-                        (GHC, GhcVersion vghc) -> vghc `withinRange` range-                        (GHC, GhcjsVersion _ vghc) -> vghc `withinRange` range-                        (GHCJS, GhcjsVersion vghcjs _) ->+                        (GHC, ACGhc vghc) -> vghc `withinRange` range+                        (GHC, ACGhcjs _ vghc) -> vghc `withinRange` range+                        (GHCJS, ACGhcjs vghcjs _) ->                           vghcjs `withinRange` range                         _ -> False  -- | Get the name of a dependency. depName :: Dependency -> PackageName-depName (Dependency n _) = fromCabalPackageName n+depName (Dependency n _) = n  -- | Get the version range of a dependency. depRange :: Dependency -> VersionRange@@ -1127,20 +1003,19 @@     :: NamedComponent       -- ^ Package component name     -> [Path Abs Dir]       -- ^ Directories to look in.     -> [DotCabalDescriptor] -- ^ Base names.-    -> [Text]               -- ^ Extensions.-    -> RIO Ctx (Map ModuleName (Path Abs File),Set DotCabalPath,[PackageWarning])-resolveFilesAndDeps component dirs names0 exts = do+    -> RIO Ctx (Map ModuleName (Path Abs File),[DotCabalPath],[PackageWarning])+resolveFilesAndDeps component dirs names0 = do     (dotCabalPaths, foundModules, missingModules) <- loop names0 S.empty     warnings <- liftM2 (++) (warnUnlisted foundModules) (warnMissing missingModules)     return (foundModules, dotCabalPaths, warnings)   where-    loop [] _ = return (S.empty, M.empty, [])+    loop [] _ = return ([], M.empty, [])     loop names doneModules0 = do-        resolved <- resolveFiles dirs names exts+        resolved <- resolveFiles dirs names         let foundFiles = mapMaybe snd resolved             foundModules = mapMaybe toResolvedModule resolved             missingModules = mapMaybe toMissingModule resolved-        pairs <- mapM (getDependencies component) foundFiles+        pairs <- mapM (getDependencies component dirs) foundFiles         let doneModules =                 S.union                     doneModules0@@ -1153,10 +1028,7 @@         (resolvedFiles, resolvedModules, _) <-             loop (map DotCabalModule (S.toList modulesRemaining)) doneModules         return-            ( S.union-                  (S.fromList-                       (foundFiles <> map DotCabalFilePath thDepFiles))-                  resolvedFiles+            ( nubOrd $ foundFiles <> map DotCabalFilePath thDepFiles <> resolvedFiles             , M.union                   (M.fromList foundModules)                   resolvedModules@@ -1204,8 +1076,8 @@  -- | Get the dependencies of a Haskell module file. getDependencies-    :: NamedComponent -> DotCabalPath -> RIO Ctx (Set ModuleName, [Path Abs File])-getDependencies component dotCabalPath =+    :: NamedComponent -> [Path Abs Dir] -> DotCabalPath -> RIO Ctx (Set ModuleName, [Path Abs File])+getDependencies component dirs dotCabalPath =     case dotCabalPath of         DotCabalModulePath resolvedFile -> readResolvedHi resolvedFile         DotCabalMainPath resolvedFile -> readResolvedHi resolvedFile@@ -1215,70 +1087,50 @@     readResolvedHi resolvedFile = do         dumpHIDir <- componentOutputDir component <$> asks ctxDistDir         dir <- asks (parent . ctxFile)-        case stripProperPrefix dir resolvedFile of+        let sourceDir = fromMaybe dir $ find (`isProperPrefixOf` resolvedFile) dirs+            stripSourceDir d = stripProperPrefix d resolvedFile+        case stripSourceDir sourceDir of             Nothing -> return (S.empty, [])             Just fileRel -> do-                let dumpHIPath =+                let hiPath =                         FilePath.replaceExtension                             (toFilePath (dumpHIDir </> fileRel))-                            ".dump-hi"-                dumpHIExists <- liftIO $ D.doesFileExist dumpHIPath+                            ".hi"+                dumpHIExists <- liftIO $ D.doesFileExist hiPath                 if dumpHIExists-                    then parseDumpHI dumpHIPath+                    then parseHI hiPath                     else return (S.empty, []) --- | Parse a .dump-hi file into a set of modules and files.-parseDumpHI+-- | Parse a .hi file into a set of modules and files.+parseHI     :: FilePath -> RIO Ctx (Set ModuleName, [Path Abs File])-parseDumpHI dumpHIPath = do-    dir <- asks (parent . ctxFile)-    dumpHI <- liftIO $ filterDumpHi <$> fmap CL8.lines (CL8.readFile dumpHIPath)-    let startModuleDeps =-            dropWhile (not . ("module dependencies:" `CL8.isPrefixOf`)) dumpHI-        moduleDeps =-            S.fromList $-            mapMaybe (D.simpleParse . TL.unpack . TLE.decodeUtf8) $-            CL8.words $-            CL8.concat $-            CL8.dropWhile (/= ' ') (fromMaybe "" $ listToMaybe startModuleDeps) :-            takeWhile (" " `CL8.isPrefixOf`) (drop 1 startModuleDeps)-        thDeps =-            -- The dependent file path is surrounded by quotes but is not escaped.-            -- It can be an absolute or relative path.-                  TL.unpack .-                  -- Starting with GHC 8.4.3, there's a hash following-                  -- the path. See-                  -- https://github.com/yesodweb/yesod/issues/1551-                  TLE.decodeUtf8 .-                  CL8.takeWhile (/= '\"') <$>-            mapMaybe (CL8.stripPrefix "addDependentFile \"") dumpHI-    thDepsResolved <- liftM catMaybes $ forM thDeps $ \x -> do-        mresolved <- liftIO (forgivingAbsence (resolveFile dir x)) >>= rejectMissingFile-        when (isNothing mresolved) $-            prettyWarnL-                [ flow "addDependentFile path (Template Haskell) listed in"-                , styleFile $ fromString dumpHIPath-                , flow "does not exist:"-                , styleFile $ fromString x-                ]-        return mresolved-    return (moduleDeps, thDepsResolved)-  where-    -- | Filtering step fixing RAM usage upon a big dump-hi file. See-    --   https://github.com/commercialhaskell/stack/issues/4027 It is-    --   an optional step from a functionality stand-point.-    filterDumpHi dumpHI =-        let dl x xs = x ++ xs-            isLineInteresting (acc, moduleDepsStarted) l-                | moduleDepsStarted && " " `CL8.isPrefixOf` l =-                    (acc . dl [l], True)-                | "module dependencies:" `CL8.isPrefixOf` l =-                    (acc . dl [l], True)-                | "addDependentFile \"" `CL8.isPrefixOf` l =-                    (acc . dl [l], False)-                | otherwise = (acc, False)-         in fst (foldl' isLineInteresting (dl [], False) dumpHI) []-+parseHI hiPath = do+  dir <- asks (parent . ctxFile)+  result <- liftIO $ Iface.fromFile hiPath+  case result of+    Left msg -> do+      prettyWarnL+        [ flow "Failed to decode module interface:"+        , style File $ fromString hiPath+        , flow "Decoding failure:"+        , style Error $ fromString msg+        ]+      pure (S.empty, [])+    Right iface -> do+      let moduleNames = fmap (fromString . B8.unpack . fst) . Iface.unList . Iface.dmods . Iface.deps+          resolveFileDependency file = do+            resolved <- liftIO (forgivingAbsence (resolveFile dir file)) >>= rejectMissingFile+            when (isNothing resolved) $+              prettyWarnL+              [ flow "Dependent file listed in:"+              , style File $ fromString hiPath+              , flow "does not exist:"+              , style File $ fromString file+              ]+            pure resolved+          resolveUsages = traverse (resolveFileDependency . Iface.unUsage) . Iface.unList . Iface.usage+      resolvedUsages <- catMaybes <$> resolveUsages iface+      pure (S.fromList $ moduleNames iface, resolvedUsages)  -- | Try to resolve the list of base names in the given directory by -- looking for unique instances of base names applied with the given@@ -1286,19 +1138,38 @@ resolveFiles     :: [Path Abs Dir] -- ^ Directories to look in.     -> [DotCabalDescriptor] -- ^ Base names.-    -> [Text] -- ^ Extensions.     -> RIO Ctx [(DotCabalDescriptor, Maybe DotCabalPath)]-resolveFiles dirs names exts =-    forM names (\name -> liftM (name, ) (findCandidate dirs exts name))+resolveFiles dirs names =+    forM names (\name -> liftM (name, ) (findCandidate dirs name)) +data CabalFileNameParseFail+  = CabalFileNameParseFail FilePath+  | CabalFileNameInvalidPackageName FilePath+  deriving (Typeable)++instance Exception CabalFileNameParseFail+instance Show CabalFileNameParseFail where+    show (CabalFileNameParseFail fp) = "Invalid file path for cabal file, must have a .cabal extension: " ++ fp+    show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp++-- | Parse a package name from a file path.+parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName+parsePackageNameFromFilePath fp = do+    base <- clean $ toFilePath $ filename fp+    case parsePackageName base of+        Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp+        Just x -> return x+  where clean = liftM reverse . strip . reverse+        strip ('l':'a':'b':'a':'c':'.':xs) = return xs+        strip _ = throwM (CabalFileNameParseFail (toFilePath fp))+ -- | Find a candidate for the given module-or-filename from the list -- of directories and given extensions. findCandidate     :: [Path Abs Dir]-    -> [Text]     -> DotCabalDescriptor     -> RIO Ctx (Maybe DotCabalPath)-findCandidate dirs exts name = do+findCandidate dirs name = do     pkg <- asks ctxFile >>= parsePackageNameFromFilePath     candidates <- liftIO makeNameCandidates     case candidates of@@ -1329,22 +1200,35 @@             DotCabalMain fp -> resolveCandidate dir fp             DotCabalFile fp -> resolveCandidate dir fp             DotCabalCFile fp -> resolveCandidate dir fp-            DotCabalModule mn ->-                liftM concat-                $ mapM-                  ((\ ext ->-                     resolveCandidate dir (Cabal.toFilePath mn ++ "." ++ ext))-                   . T.unpack)-                   exts-    resolveCandidate-        :: (MonadIO m, MonadThrow m)-        => Path Abs Dir -> FilePath.FilePath -> m [Path Abs File]-    resolveCandidate x y = do-        -- The standard canonicalizePath does not work for this case-        p <- parseCollapsedAbsFile (toFilePath x FilePath.</> y)-        exists <- doesFileExist p-        return $ if exists then [p] else []+            DotCabalModule mn -> do+              let perExt ext =+                     resolveCandidate dir (Cabal.toFilePath mn ++ "." ++ T.unpack ext)+              withHaskellExts <- mapM perExt haskellFileExts+              withPPExts <- mapM perExt haskellPreprocessorExts+              pure $+                case (concat withHaskellExts, concat withPPExts) of+                  -- If we have exactly 1 Haskell extension and exactly+                  -- 1 preprocessor extension, assume the former file is+                  -- generated from the latter+                  --+                  -- See https://github.com/commercialhaskell/stack/issues/4076+                  ([_], [y]) -> [y] +                  -- Otherwise, return everything+                  (xs, ys) -> xs ++ ys+    resolveCandidate dir = fmap maybeToList . resolveDirFile dir++-- | Resolve file as a child of a specified directory, symlinks+-- don't get followed.+resolveDirFile+    :: (MonadIO m, MonadThrow m)+    => Path Abs Dir -> FilePath.FilePath -> m (Maybe (Path Abs File))+resolveDirFile x y = do+    -- The standard canonicalizePath does not work for this case+    p <- parseCollapsedAbsFile (toFilePath x FilePath.</> y)+    exists <- doesFileExist p+    return $ if exists then Just p else Nothing+ -- | Warn the user that multiple candidates are available for an -- entry, but that we picked one anyway and continued. warnMultiple@@ -1352,9 +1236,9 @@ warnMultiple name candidate rest =     -- TODO: figure out how to style 'name' and the dispOne stuff     prettyWarnL-        [ flow "There were multiple candidates for the Cabal entry \""+        [ flow "There were multiple candidates for the Cabal entry"         , fromString . showName $ name-        , line <> bulletedList (map dispOne rest)+        , line <> bulletedList (map dispOne (candidate:rest))         , line <> flow "picking:"         , dispOne candidate         ]@@ -1372,15 +1256,15 @@ -- For example: .erb for a Ruby file might exist in one of the -- directories. logPossibilities-    :: HasRunner env+    :: HasTerm env     => [Path Abs Dir] -> ModuleName -> RIO env () logPossibilities dirs mn = do     possibilities <- liftM concat (makePossibilities mn)     unless (null possibilities) $ prettyWarnL         [ flow "Unable to find a known candidate for the Cabal entry"-        , (styleModule . fromString $ D.display mn) <> ","+        , (style PP.Module . fromString $ D.display mn) <> ","         , flow "but did find:"-        , line <> bulletedList (map display possibilities)+        , line <> bulletedList (map pretty possibilities)         , flow "If you are using a custom preprocessor for this module"         , flow "with its own file extension, consider adding the file(s)"         , flow "to your .cabal under extra-source-files."@@ -1399,79 +1283,6 @@                                    files)))             dirs --- | Get the filename for the cabal file in the given directory.------ If no .cabal file is present, or more than one is present, an exception is--- thrown via 'throwM'.------ If the directory contains a file named package.yaml, hpack is used to--- generate a .cabal file from it.-findOrGenerateCabalFile-    :: forall env. HasConfig env-    => Path Abs Dir -- ^ package directory-    -> RIO env (Path Abs File)-findOrGenerateCabalFile pkgDir = do-    hpack pkgDir-    findCabalFile-  where-    findCabalFile :: RIO env (Path Abs File)-    findCabalFile = findCabalFile' >>= either throwIO return--    findCabalFile' :: RIO env (Either PackageException (Path Abs File))-    findCabalFile' = do-        files <- liftIO $ findFiles-            pkgDir-            (flip hasExtension "cabal" . FL.toFilePath)-            (const False)-        return $ case files of-            [] -> Left $ PackageNoCabalFileFound pkgDir-            [x] -> Right x-            -- If there are multiple files, ignore files that start with-            -- ".". On unixlike environments these are hidden, and this-            -- character is not valid in package names. The main goal is-            -- to ignore emacs lock files - see-            -- https://github.com/commercialhaskell/stack/issues/1897.-            (filter (not . ("." `isPrefixOf`) . toFilePath . filename) -> [x]) -> Right x-            _:_ -> Left $ PackageMultipleCabalFilesFound pkgDir files-      where hasExtension fp x = FilePath.takeExtension fp == "." ++ x---- | Generate .cabal file from package.yaml, if necessary.-hpack :: HasConfig env => Path Abs Dir -> RIO env ()-hpack pkgDir = do-    let hpackFile = pkgDir </> $(mkRelFile Hpack.packageConfig)-    exists <- liftIO $ doesFileExist hpackFile-    when exists $ do-        prettyDebugL [flow "Running hpack on", display hpackFile]--        config <- view configL-        case configOverrideHpack config of-            HpackBundled -> do-                r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions-                forM_ (Hpack.resultWarnings r) prettyWarnS-                let cabalFile = styleFile . fromString . Hpack.resultCabalFile $ r-                case Hpack.resultStatus r of-                    Hpack.Generated -> prettyDebugL-                        [flow "hpack generated a modified version of", cabalFile]-                    Hpack.OutputUnchanged -> prettyDebugL-                        [flow "hpack output unchanged in", cabalFile]-                    Hpack.AlreadyGeneratedByNewerHpack -> prettyWarnL-                        [ cabalFile-                        , flow "was generated with a newer version of hpack,"-                        , flow "please upgrade and try again."-                        ]-                    Hpack.ExistingCabalFileWasModifiedManually -> prettyWarnL-                        [ cabalFile-                        , flow "was modified manually. Ignoring"-                        , display hpackFile-                        , flow "in favor of the cabal file. If you want to use the"-                        , display . filename $ hpackFile-                        , flow "file instead of the cabal file,"-                        , flow "then please delete the cabal file."-                        ]-            HpackCommand command ->-                withWorkingDir (toFilePath pkgDir) $-                proc command [] runProcess_- -- | Path for the package's build log. buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m)              => Package -> Maybe String -> m (Path Abs File)@@ -1481,7 +1292,7 @@   fp <- parseRelFile $ concat $     packageIdentifierString (packageIdentifier package') :     maybe id (\suffix -> ("-" :) . (suffix :)) msuffix [".log"]-  return $ stack </> $(mkRelDir "logs") </> fp+  return $ stack </> relDirLogs </> fp  -- Internal helper to define resolveFileOrWarn and resolveDirOrWarn resolveOrWarn :: Text@@ -1493,16 +1304,19 @@      file <- asks ctxFile      dir <- asks (parent . ctxFile)      result <- resolver dir path-     when (isNothing result) $-       prettyWarnL-           [ fromString . T.unpack $ subject -- TODO: needs style?-           , flow "listed in"-           , maybe (display file) display (stripProperPrefix cwd file)-           , flow "file does not exist:"-           , styleDir . fromString $ path-           ]+     when (isNothing result) $ warnMissingFile subject cwd path file      return result +warnMissingFile :: Text -> Path Abs Dir -> FilePath -> Path Abs File -> RIO Ctx ()+warnMissingFile subject cwd path fromFile =+    prettyWarnL+        [ fromString . T.unpack $ subject -- TODO: needs style?+        , flow "listed in"+        , maybe (pretty fromFile) pretty (stripProperPrefix cwd fromFile)+        , flow "file does not exist:"+        , style Dir . fromString $ path+        ]+ -- | Resolve the file, if it can't be resolved, warn for the user -- (purely to be helpful). resolveFileOrWarn :: FilePath.FilePath@@ -1517,16 +1331,65 @@ resolveDirOrWarn = resolveOrWarn "Directory" f   where f p x = liftIO (forgivingAbsence (resolveDir p x)) >>= rejectMissingDir --- | Extract the @PackageIdentifier@ given an exploded haskell package--- path.-cabalFilePackageId-    :: (MonadIO m, MonadThrow m)-    => Path Abs File -> m PackageIdentifier-cabalFilePackageId fp = do-    pkgDescr <- liftIO (D.readGenericPackageDescription D.silent $ toFilePath fp)-    (toStackPI . D.package . D.packageDescription) pkgDescr+    {- FIXME+-- | Create a 'ProjectPackage' from a directory containing a package.+mkProjectPackage+  :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)+  => PrintWarnings+  -> ResolvedPath Dir+  -> RIO env ProjectPackage+mkProjectPackage printWarnings dir = do+  (gpd, name, cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)+  return ProjectPackage+    { ppCabalFP = cabalfp+    , ppGPD' = gpd printWarnings+    , ppResolvedDir = dir+    , ppName = name+    }++-- | Create a 'DepPackage' from a 'PackageLocation'+mkDepPackage+  :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)+  => PackageLocation+  -> RIO env DepPackage+mkDepPackage pl = do+  (name, gpdio) <-+    case pl of+      PLMutable dir -> do+        (gpdio, name, _cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)+        pure (name, gpdio NoPrintWarnings)+      PLImmutable pli -> do+        PackageIdentifier name _ <- getPackageLocationIdent pli+        run <- askRunInIO+        pure (name, run $ loadCabalFileImmutable pli)+  return DepPackage+    { dpGPD' = gpdio+    , dpLocation = pl+    , dpName = name+    }++    -}++-- | Force a package to be treated as a custom build type, see+-- <https://github.com/commercialhaskell/stack/issues/4488>+applyForceCustomBuild+  :: Version -- ^ global Cabal version+  -> Package+  -> Package+applyForceCustomBuild cabalVersion package+    | forceCustomBuild =+        package+          { packageBuildType = Custom+          , packageDeps = M.insertWith (<>) "Cabal" (DepValue cabalVersionRange AsLibrary)+                        $ packageDeps package+          , packageSetupDeps = Just $ M.fromList+              [ ("Cabal", cabalVersionRange)+              , ("base", anyVersion)+              ]+          }+    | otherwise = package   where-    toStackPI (D.PackageIdentifier (D.unPackageName -> name) ver) = do-        name' <- parsePackageNameFromString name-        let ver' = fromCabalVersion ver-        return (PackageIdentifier name' ver')+    cabalVersionRange = packageCabalSpec package+    forceCustomBuild =+      packageBuildType package == Simple &&+      not (cabalVersion `withinRange` cabalVersionRange)
src/Stack/PackageDump.hs view
@@ -1,12 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-} module Stack.PackageDump     ( Line     , eachSection@@ -15,12 +12,6 @@     , conduitDumpPackage     , ghcPkgDump     , ghcPkgDescribe-    , newInstalledCache-    , loadInstalledCache-    , saveInstalledCache-    , addProfiling-    , addHaddock-    , addSymbols     , sinkMatching     , pruneDeps     ) where@@ -31,58 +22,48 @@ import           Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Conduit.Text as CT-import           Data.List (isPrefixOf) import qualified Data.Map as Map import qualified Data.Set as Set-import           Data.Store.VersionTagged-import qualified Data.Text as T-import qualified Distribution.License as C-import qualified Distribution.System as OS+import qualified RIO.Text as T import qualified Distribution.Text as C import           Path.Extra (toFilePathNoTrailingSep) import           Stack.GhcPkg-import           Stack.Types.Compiler+import           Stack.Types.Config (HasCompiler (..), GhcPkgExe (..), DumpPackage (..)) import           Stack.Types.GhcPkgId-import           Stack.Types.PackageDump-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Version-import           System.Directory (getDirectoryContents, doesFileExist)-import           System.Process (readProcess) -- FIXME confirm that this is correct import           RIO.Process hiding (readProcess)  -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump     :: (HasProcessContext env, HasLogFunc env)-    => WhichCompiler+    => GhcPkgExe     -> [Path Abs Dir] -- ^ if empty, use global     -> ConduitM Text Void (RIO env) a     -> RIO env a-ghcPkgDump = ghcPkgCmdArgs ["dump"]+ghcPkgDump pkgexe = ghcPkgCmdArgs pkgexe ["dump"]  -- | Call ghc-pkg describe with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDescribe-    :: (HasProcessContext env, HasLogFunc env)-    => PackageName-    -> WhichCompiler+    :: (HasProcessContext env, HasLogFunc env, HasCompiler env)+    => GhcPkgExe+    -> PackageName     -> [Path Abs Dir] -- ^ if empty, use global     -> ConduitM Text Void (RIO env) a     -> RIO env a-ghcPkgDescribe pkgName = ghcPkgCmdArgs ["describe", "--simple-output", packageNameString pkgName]+ghcPkgDescribe pkgexe pkgName' = ghcPkgCmdArgs pkgexe ["describe", "--simple-output", packageNameString pkgName']  -- | Call ghc-pkg and stream to the given @Sink@, for a single database ghcPkgCmdArgs     :: (HasProcessContext env, HasLogFunc env)-    => [String]-    -> WhichCompiler+    => GhcPkgExe+    -> [String]     -> [Path Abs Dir] -- ^ if empty, use global     -> ConduitM Text Void (RIO env) a     -> RIO env a-ghcPkgCmdArgs cmd wc mpkgDbs sink = do+ghcPkgCmdArgs pkgexe@(GhcPkgExe pkgPath) cmd mpkgDbs sink = do     case reverse mpkgDbs of-        (pkgDb:_) -> createDatabase wc pkgDb -- TODO maybe use some retry logic instead?+        (pkgDb:_) -> createDatabase pkgexe pkgDb -- TODO maybe use some retry logic instead?         _ -> return ()-    sinkProcessStdout (ghcPkgExeName wc) args sink'+    sinkProcessStdout (toFilePath pkgPath) args sink'   where     args = concat         [ case mpkgDbs of@@ -94,22 +75,6 @@         ]     sink' = CT.decodeUtf8 .| sink --- | Create a new, empty @InstalledCache@-newInstalledCache :: MonadIO m => m InstalledCache-newInstalledCache = liftIO $ InstalledCache <$> newIORef (InstalledCacheInner Map.empty)---- | Load a @InstalledCache@ from disk, swallowing any errors and returning an--- empty cache.-loadInstalledCache :: HasLogFunc env => Path Abs File -> RIO env InstalledCache-loadInstalledCache path = do-    m <- $(versionedDecodeOrLoad installedCacheVC) path (return $ InstalledCacheInner Map.empty)-    liftIO $ InstalledCache <$> newIORef m---- | Save a @InstalledCache@ to disk-saveInstalledCache :: HasLogFunc env => Path Abs File -> InstalledCache -> RIO env ()-saveInstalledCache path (InstalledCache ref) =-    liftIO (readIORef ref) >>= $(versionedEncodeFile installedCacheVC) path- -- | Prune a list of possible packages down to those whose dependencies are met. -- -- * id uniquely identifies an item@@ -153,151 +118,24 @@ -- | Find the package IDs matching the given constraints with all dependencies installed. -- Packages not mentioned in the provided @Map@ are allowed to be present too. sinkMatching :: Monad m-             => Bool -- ^ require profiling?-             -> Bool -- ^ require haddock?-             -> Bool -- ^ require debugging symbols?-             -> Map PackageName Version -- ^ allowed versions-             -> ConduitM (DumpPackage Bool Bool Bool) o-                         m-                         (Map PackageName (DumpPackage Bool Bool Bool))-sinkMatching reqProfiling reqHaddock reqSymbols allowed =+             => Map PackageName Version -- ^ allowed versions+             -> ConduitM DumpPackage o m (Map PackageName DumpPackage)+sinkMatching allowed =       Map.fromList-    . map (packageIdentifierName . dpPackageIdent &&& id)+    . map (pkgName . dpPackageIdent &&& id)     . Map.elems     . pruneDeps         id         dpGhcPkgId         dpDepends         const -- Could consider a better comparison in the future-    <$> (CL.filter predicate .| CL.consume)+    <$> (CL.filter (isAllowed . dpPackageIdent) .| CL.consume)   where-    predicate dp =-      isAllowed (dpPackageIdent dp) &&-      (not reqProfiling || dpProfiling dp) &&-      (not reqHaddock || dpHaddock dp) &&-      (not reqSymbols || dpSymbols dp)-     isAllowed (PackageIdentifier name version) =         case Map.lookup name allowed of             Just version' | version /= version' -> False             _ -> True --- | Add profiling information to the stream of @DumpPackage@s-addProfiling :: MonadIO m-             => InstalledCache-             -> ConduitM (DumpPackage a b c) (DumpPackage Bool b c) m ()-addProfiling (InstalledCache ref) =-    CL.mapM go-  where-    go dp = liftIO $ do-        InstalledCacheInner m <- readIORef ref-        let gid = dpGhcPkgId dp-        p <- case Map.lookup gid m of-            Just installed -> return (installedCacheProfiling installed)-            Nothing | null (dpLibraries dp) -> return True-            Nothing -> do-                let loop [] = return False-                    loop (dir:dirs) = do-                        econtents <- tryIO $ getDirectoryContents dir-                        let contents = either (const []) id econtents-                        if or [isProfiling content lib-                              | content <- contents-                              , lib <- dpLibraries dp-                              ] && not (null contents)-                            then return True-                            else loop dirs-                loop $ dpLibDirs dp-        return dp { dpProfiling = p }--isProfiling :: FilePath -- ^ entry in directory-            -> Text -- ^ name of library-            -> Bool-isProfiling content lib =-    prefix `T.isPrefixOf` T.pack content-  where-    prefix = T.concat ["lib", lib, "_p"]---- | Add haddock information to the stream of @DumpPackage@s-addHaddock :: MonadIO m-           => InstalledCache-           -> ConduitM (DumpPackage a b c) (DumpPackage a Bool c) m ()-addHaddock (InstalledCache ref) =-    CL.mapM go-  where-    go dp = liftIO $ do-        InstalledCacheInner m <- readIORef ref-        let gid = dpGhcPkgId dp-        h <- case Map.lookup gid m of-            Just installed -> return (installedCacheHaddock installed)-            Nothing | not (dpHasExposedModules dp) -> return True-            Nothing -> do-                let loop [] = return False-                    loop (ifc:ifcs) = do-                        exists <- doesFileExist ifc-                        if exists-                            then return True-                            else loop ifcs-                loop $ dpHaddockInterfaces dp-        return dp { dpHaddock = h }---- | Add debugging symbol information to the stream of @DumpPackage@s-addSymbols :: MonadIO m-           => InstalledCache-           -> ConduitM (DumpPackage a b c) (DumpPackage a b Bool) m ()-addSymbols (InstalledCache ref) =-    CL.mapM go-  where-    go dp = do-        InstalledCacheInner m <- liftIO $ readIORef ref-        let gid = dpGhcPkgId dp-        s <- case Map.lookup gid m of-            Just installed -> return (installedCacheSymbols installed)-            Nothing | null (dpLibraries dp) -> return True-            Nothing ->-              case dpLibraries dp of-                [] -> return True-                lib:_ ->-                  liftM or . mapM (\dir -> liftIO $ hasDebuggingSymbols dir (T.unpack lib)) $ dpLibDirs dp-        return dp { dpSymbols = s }--hasDebuggingSymbols :: FilePath -- ^ library directory-                    -> String   -- ^ name of library-                    -> IO Bool-hasDebuggingSymbols dir lib = do-    let path = concat [dir, "/lib", lib, ".a"]-    exists <- doesFileExist path-    if not exists then return False-    else case OS.buildOS of-        OS.OSX     -> liftM (any (isPrefixOf "0x") . lines) $-            readProcess "dwarfdump" [path] ""-        OS.Linux   -> liftM (any (isPrefixOf "Contents") . lines) $-            readProcess "readelf" ["--debug-dump=info", "--dwarf-depth=1", path] ""-        OS.FreeBSD -> liftM (any (isPrefixOf "Contents") . lines) $-            readProcess "readelf" ["--debug-dump=info", "--dwarf-depth=1", path] ""-        OS.Windows -> return False -- No support, so it can't be there.-        _          -> return False----- | Dump information for a single package-data DumpPackage profiling haddock symbols = DumpPackage-    { dpGhcPkgId :: !GhcPkgId-    , dpPackageIdent :: !PackageIdentifier-    , dpParentLibIdent :: !(Maybe PackageIdentifier)-    , dpLicense :: !(Maybe C.License)-    , dpLibDirs :: ![FilePath]-    , dpLibraries :: ![Text]-    , dpHasExposedModules :: !Bool-    , dpExposedModules :: ![Text]-    , dpDepends :: ![GhcPkgId]-    , dpHaddockInterfaces :: ![FilePath]-    , dpHaddockHtml :: !(Maybe FilePath)-    , dpProfiling :: !profiling-    , dpHaddock :: !haddock-    , dpSymbols :: !symbols-    , dpIsExposed :: !Bool-    }-    deriving (Show, Eq)- data PackageDumpException     = MissingSingleField Text (Map Text [Line])     | Couldn'tParseField Text [Line]@@ -315,7 +153,7 @@  -- | Convert a stream of bytes into a stream of @DumpPackage@s conduitDumpPackage :: MonadThrow m-                   => ConduitM Text (DumpPackage () () ()) m ()+                   => ConduitM Text DumpPackage m () conduitDumpPackage = (.| CL.catMaybes) $ eachSection $ do     pairs <- eachPair (\k -> (k, ) <$> CL.consume) .| CL.consume     let m = Map.fromList pairs@@ -342,8 +180,8 @@     case Map.lookup "id" m of         Just ["builtin_rts"] -> return Nothing         _ -> do-            name <- parseS "name" >>= parsePackageName-            version <- parseS "version" >>= parseVersion+            name <- parseS "name" >>= parsePackageNameThrowing . T.unpack+            version <- parseS "version" >>= parseVersionThrowing . T.unpack             ghcPkgId <- parseS "id" >>= parseGhcPkgId              -- if a package has no modules, these won't exist@@ -360,7 +198,8 @@             -- Handle sublibs by recording the name of the parent library             -- If name of parent library is missing, this is not a sublib.             let mkParentLib n = PackageIdentifier n version-                parentLib = mkParentLib <$> (parseS "package-name" >>= parsePackageName)+                parentLib = mkParentLib <$> (parseS "package-name" >>=+                                             parsePackageNameThrowing . T.unpack)              let parseQuoted key =                     case mapM (P.parseOnly (argsParser NoEscaping)) val of@@ -380,13 +219,18 @@                 , dpLibDirs = libDirPaths                 , dpLibraries = T.words $ T.unwords libraries                 , dpHasExposedModules = not (null libraries || null exposedModules)-                , dpExposedModules = T.words $ T.unwords exposedModules++                -- Strip trailing commas from ghc package exposed-modules (looks buggy to me...).+                -- Then try to parse the module names.+                , dpExposedModules =+                      Set.fromList+                    $ mapMaybe (C.simpleParse . T.unpack . T.dropSuffix ",")+                    $ T.words+                    $ T.unwords exposedModules+                 , dpDepends = depends                 , dpHaddockInterfaces = haddockInterfaces                 , dpHaddockHtml = listToMaybe haddockHtml-                , dpProfiling = ()-                , dpHaddock = ()-                , dpSymbols = ()                 , dpIsExposed = exposed == ["True"]                 }
− src/Stack/PackageIndex.hs 
@@ -1,503 +0,0 @@-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE PatternGuards              #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE ViewPatterns               #-}-{-# LANGUAGE ScopedTypeVariables        #-}---- | Dealing with the 01-index file and all its cabal files.-module Stack.PackageIndex-    ( updateAllIndices-    , getPackageCaches-    , getPackageVersions-    , lookupPackageVersions-    , CabalLoader (..)-    , HasCabalLoader (..)-    , configPackageIndex-    , configPackageIndexRoot-    ) where--import qualified Codec.Archive.Tar as Tar-import           Stack.Prelude-import           Data.Aeson.Extended-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy as L-import           Data.Conduit.Zlib (ungzip)-import qualified Data.List.NonEmpty as NE-import qualified Data.HashMap.Strict as HashMap-import           Data.Store.Version-import           Data.Store.VersionTagged-import qualified Data.Text as T-import           Data.Text.Unsafe (unsafeTail)-import           Data.Time (getCurrentTime)-import qualified Hackage.Security.Client as HS-import qualified Hackage.Security.Client.Repository.Cache as HS-import qualified Hackage.Security.Client.Repository.Remote as HS-import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS-import qualified Hackage.Security.Util.Path as HS-import qualified Hackage.Security.Util.Pretty as HS-import           Network.HTTP.StackClient (getGlobalManager)-import           Network.HTTP.Download-import           Network.URI (parseURI)-import           Path (toFilePath, parseAbsFile, mkRelDir, mkRelFile, (</>), parseRelDir)-import           Path.Extra (tryGetModificationTime)-import           Path.IO-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageIndex-import           Stack.Types.PackageName-import           Stack.Types.Runner (HasRunner)-import           Stack.Types.Version-import qualified System.Directory as D-import           System.FilePath ((<.>))---- | Populate the package index caches and return them.-populateCache :: HasCabalLoader env => PackageIndex -> RIO env (PackageCache ())-populateCache index = do-    requireIndex index-    -- This uses full on lazy I/O instead of ResourceT to provide some-    -- protections. Caveat emptor-    path <- configPackageIndex (indexName index)-    let loadPIS = withLazyFile (Path.toFilePath path) $ \lbs -> do-            logSticky "Populating index cache ..."-            loop 0 HashMap.empty (Tar.read lbs)-    pis0 <- loadPIS `catch` \e -> do-        logWarn $ "Exception encountered when parsing index tarball: "-                <> displayShow (e :: Tar.FormatError)-        logWarn "Automatically updating index and trying again"-        updateIndex index-        loadPIS--    when (indexRequireHashes index) $ forM_ (HashMap.toList pis0) $ \(ident, (mpd, _)) ->-        case mpd :: Maybe PackageDownload of-            Just _ -> return ()-            Nothing -> throwM $ MissingRequiredHashes (indexName index) ident--    cache <- fmap mconcat $ mapM convertPI $ HashMap.toList pis0--    logStickyDone "Populated index cache."--    return cache-  where-    convertPI :: MonadIO m-              => (PackageIdentifier, (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)]))-              -> m (PackageCache ())-    convertPI (ident@(PackageIdentifier name version), (mpd, Endo front)) =-      case NE.nonEmpty $ front [] of-        Nothing -> throwString $ "Missing cabal file info for: " ++ show ident-        Just files -> return-                    $ PackageCache-                    $ HashMap.singleton name-                    $ HashMap.singleton version-                      ((), mpd, files)--    loop :: MonadThrow m-         => Int64-         -> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)])-         -> Tar.Entries Tar.FormatError-         -> m (HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)]))-    loop !blockNo !m (Tar.Next e es) =-        loop (blockNo + entrySizeInBlocks e) (goE blockNo m e) es-    loop _ m Tar.Done = return m-    loop _ _ (Tar.Fail e) = throwM e--    goE :: Int64-        -> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)])-        -> Tar.Entry-        -> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)])-    goE blockNo m e =-        case Tar.entryContent e of-            Tar.NormalFile lbs size ->-                case parseNameVersionSuffix $ Tar.entryPath e of-                    Just (ident, ".cabal") -> addCabal lbs ident size-                    Just (ident, ".json") -> addJSON id ident lbs-                    _ ->-                        case parsePackageJSON $ Tar.entryPath e of-                            Just ident -> addJSON unHSPackageDownload ident lbs-                            Nothing -> m-            _ -> m-      where-        addCabal lbs ident size = HashMap.alter-            (\case-                Nothing -> Just (Nothing, newEndo)-                Just (mpd, oldEndo) -> Just (mpd, oldEndo <> newEndo))-            ident-            m-          where-            !cabalHash = computeCabalHash lbs--            -- Some older Stackage snapshots ended up with slightly-            -- modified cabal files, in particular having DOS-style-            -- line endings (CRLF) converted to Unix-style (LF). As a-            -- result, we track both hashes with and without CR-            -- characters stripped for compatibility with these older-            -- snapshots.-            cr = 13-            cabalHashes-              | cr `L.elem` lbs =-                  let !cabalHash' = computeCabalHash (L.filter (/= cr) lbs)-                   in [cabalHash, cabalHash']-              | otherwise = [cabalHash]-            offsetSize = OffsetSize ((blockNo + 1) * 512) size-            newPair = (cabalHashes, offsetSize)-            newEndo = Endo (newPair:)--        addJSON :: FromJSON a-                => (a -> PackageDownload)-                -> PackageIdentifier-                -> L.ByteString-                -> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)])-        addJSON unwrap ident lbs =-            case decode lbs of-                Nothing -> m-                Just (unwrap -> pd) -> HashMap.alter-                  (\case-                    Nothing -> Just (Just pd, mempty)-                    Just (Just oldPD, _)-                      | oldPD /= pd -> error $ concat-                        [ "Conflicting package hash information discovered for "-                        , packageIdentifierString ident-                        , "\nFound both: \n- "-                        , show oldPD-                        , "\n- "-                        , show pd-                        , "\n\nThis should not happen. See: https://github.com/haskell/hackage-security/issues/189"-                        ]-                    Just (_, files) -> Just (Just pd, files))-                  ident-                  m--    breakSlash x-        | T.null z = Nothing-        | otherwise = Just (y, unsafeTail z)-      where-        (y, z) = T.break (== '/') x--    parseNameVersion t1 = do-        (p', t3) <- breakSlash-                  $ T.map (\c -> if c == '\\' then '/' else c)-                  $ T.pack t1-        p <- parsePackageName p'-        (v', t5) <- breakSlash t3-        v <- parseVersion v'-        return (p', p, v, t5)--    parseNameVersionSuffix t1 = do-        (p', p, v, t5) <- parseNameVersion t1-        let (t6, suffix) = T.break (== '.') t5-        guard $ t6 == p'-        return (PackageIdentifier p v, suffix)--    parsePackageJSON t1 = do-        (_, p, v, t5) <- parseNameVersion t1-        guard $ t5 == "package.json"-        return $ PackageIdentifier p v--data PackageIndexException-  = GitNotAvailable IndexName-  | MissingRequiredHashes IndexName PackageIdentifier-  deriving Typeable-instance Exception PackageIndexException-instance Show PackageIndexException where-    show (GitNotAvailable name) = concat-        [ "Package index "-        , T.unpack $ indexNameText name-        , " only provides Git access, and you do not have"-        , " the git executable on your PATH"-        ]-    show (MissingRequiredHashes name ident) = concat-        [ "Package index "-        , T.unpack $ indexNameText name-        , " is configured to require package hashes, but no"-        , " hash is available for "-        , packageIdentifierString ident-        ]---- | Require that an index be present, updating if it isn't.-requireIndex :: HasCabalLoader env => PackageIndex -> RIO env ()-requireIndex index = do-    tarFile <- configPackageIndex $ indexName index-    exists <- doesFileExist tarFile-    unless exists $ updateIndex index---- | Update all of the package indices-updateAllIndices :: HasCabalLoader env => RIO env ()-updateAllIndices = do-    clearPackageCaches-    cl <- view cabalLoaderL-    mapM_ updateIndex (clIndices cl)---- | Update the index tarball-updateIndex :: HasCabalLoader env => PackageIndex -> RIO env ()-updateIndex index =-  do let name = indexName index-         url = indexLocation index-     logSticky $ "Updating package index "-               <> display (indexNameText (indexName index))-               <> " (mirrored at "-               <> display url-               <> ") ..."-     case indexType index of-       ITVanilla -> updateIndexHTTP name url-       ITHackageSecurity hs -> updateIndexHackageSecurity name url hs-     logStickyDone "Update complete"--     -- Copy to the 00-index.tar filename for backwards-     -- compatibility. First wipe out the cache file if present.-     tarFile <- configPackageIndex name-     oldTarFile <- configPackageIndexOld name-     oldCacheFile <- configPackageIndexCacheOld name-     liftIO $ ignoringAbsence (removeFile oldCacheFile)-     withSourceFile (toFilePath tarFile) $ \src ->-       withSinkFile (toFilePath oldTarFile) $ \sink ->-       runConduit $ src .| sink---- | Update the index tarball via HTTP-updateIndexHTTP :: HasCabalLoader env-                => IndexName-                -> Text -- ^ url-                -> RIO env ()-updateIndexHTTP indexName' url = do-    req <- parseRequest $ T.unpack url-    logInfo ("Downloading package index from " <> display url)-    gz <- configPackageIndexGz indexName'-    tar <- configPackageIndex indexName'-    wasDownloaded <- redownload req gz-    shouldUnpack <--        if wasDownloaded-            then return True-            else not `liftM` doesFileExist tar--    if not shouldUnpack-        then packageIndexNotUpdated indexName'-        else do-            let tmp = toFilePath tar <.> "tmp"-            tmpPath <- parseAbsFile tmp--            deleteCache indexName'--            liftIO $ do-                withSourceFile (toFilePath gz) $ \input ->-                  withSinkFile tmp $ \output -> -- FIXME use withSinkFileCautious-                  runConduit $ input .| ungzip .| output-                renameFile tmpPath tar---- | Update the index tarball via Hackage Security-updateIndexHackageSecurity-    :: HasCabalLoader env-    => IndexName-    -> Text -- ^ base URL-    -> HackageSecurity-    -> RIO env ()-updateIndexHackageSecurity indexName' url (HackageSecurity keyIds threshold) = do-    baseURI <--        case parseURI $ T.unpack url of-            Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url-            Just x -> return x-    manager <- liftIO getGlobalManager-    root <- configPackageIndexRoot indexName'-    run <- askRunInIO-    let logTUF = run . logInfo . fromString . HS.pretty-        withRepo = HS.withRepository-            (HS.makeHttpLib manager)-            [baseURI]-            HS.defaultRepoOpts-            HS.Cache-                { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root-                , HS.cacheLayout = HS.cabalCacheLayout-                    -- Have Hackage Security write to a temporary file-                    -- to avoid invalidating the cache... continued-                    -- below at case didUpdate-                    { HS.cacheLayoutIndexTar = HS.rootPath $ HS.fragment "01-index.tar-tmp"-                    }-                }-            HS.hackageRepoLayout-            HS.hackageIndexLayout-            logTUF-    didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do-        needBootstrap <- HS.requiresBootstrap repo-        when needBootstrap $ do-            HS.bootstrap-                repo-                (map (HS.KeyId . T.unpack) keyIds)-                (HS.KeyThreshold (fromIntegral threshold))-        now <- getCurrentTime-        HS.checkForUpdates repo (Just now)--    case didUpdate of-        HS.NoUpdates -> packageIndexNotUpdated indexName'-        HS.HasUpdates -> do-            -- The index actually updated. Delete the old cache, and-            -- then move the temporary unpacked file to its real-            -- location-            tar <- configPackageIndex indexName'-            deleteCache indexName'-            liftIO $ D.renameFile (toFilePath tar ++ "-tmp") (toFilePath tar)-            logInfo "Updated package index downloaded"---- If the index is newer than the cache, delete it so that--- the next 'getPackageCaches' call recomputes it. This--- could happen if a prior run of stack updated the index,--- but exited before deleting the cache.------ See https://github.com/commercialhaskell/stack/issues/3033-packageIndexNotUpdated :: HasCabalLoader env => IndexName -> RIO env ()-packageIndexNotUpdated indexName' = do-    mindexModTime <- tryGetModificationTime =<< configPackageIndex indexName'-    mcacheModTime <- tryGetModificationTime =<< configPackageIndexCache indexName'-    case (mindexModTime, mcacheModTime) of-        (Right indexModTime, Right cacheModTime) | cacheModTime < indexModTime -> do-            deleteCache indexName'-            logInfo "No updates to your package index were found, but clearing the index cache as it is older than the index."-        (Left _, _) -> do-            deleteCache indexName'-            logError "Error: No updates to your package index were found, but downloaded index is missing."-        _ -> logInfo "No updates to your package index were found"---- | Delete the package index cache-deleteCache :: HasCabalLoader env => IndexName -> RIO env ()-deleteCache indexName' = do-    fp <- configPackageIndexCache indexName'-    eres <- liftIO $ tryIO $ removeFile fp-    case eres of-        Left e -> logDebug $ "Could not delete cache: " <> displayShow e-        Right () -> logDebug $ "Deleted index cache at " <> fromString (toFilePath fp)---- | Get the known versions for a given package from the package caches.------ See 'getPackageCaches' for performance notes.-getPackageVersions :: HasCabalLoader env => PackageName -> RIO env (HashMap Version (Maybe CabalHash))-getPackageVersions pkgName = lookupPackageVersions pkgName <$> getPackageCaches--lookupPackageVersions :: PackageName -> PackageCache index -> HashMap Version (Maybe CabalHash)-lookupPackageVersions pkgName (PackageCache m) =-    maybe HashMap.empty (HashMap.map extractOrigRevHash) $ HashMap.lookup pkgName m-  where-    -- Extract the original cabal file hash (the first element of the one or two-    -- element list currently representing the cabal file hashes).-    extractOrigRevHash (_,_, neRevHashesAndOffsets) =-      listToMaybe $ fst (NE.last neRevHashesAndOffsets)---- | Load the package caches, or create the caches if necessary.------ This has two levels of caching: in memory, and the on-disk cache. So,--- feel free to call this function multiple times.-getPackageCaches :: HasCabalLoader env => RIO env (PackageCache PackageIndex)-getPackageCaches = do-    cl <- view cabalLoaderL-    mcached <- readIORef (clCache cl)-    case mcached of-        Just cached -> return cached-        Nothing -> do-            result <- liftM mconcat $ forM (clIndices cl) $ \index -> do-                fp <- configPackageIndexCache (indexName index)-                PackageCache pis <--#if MIN_VERSION_template_haskell(2,14,0)-                    $(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "35_zXZ4b4CIWfrLXtjWteR4nb6o="-#elif MIN_VERSION_template_haskell(2,13,0)-                    $(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "LLL6OCcimOqRm3r0JmsSlLHcaLE="-#else-                    $(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "A607WaDwhg5VVvZTxNgU9g52DO8="-#endif-                                             :: VersionConfig (PackageCache ())))-                    fp-                    (populateCache index)-                return $ PackageCache ((fmap.fmap) (\((), mpd, files) -> (index, mpd, files)) pis)-            liftIO $ writeIORef (clCache cl) (Just result)-            return result---- | Clear the in-memory hackage index cache. This is needed when the--- hackage index is updated.-clearPackageCaches :: HasCabalLoader env => RIO env ()-clearPackageCaches = do-  cl <- view cabalLoaderL-  writeIORef (clCache cl) Nothing--class HasRunner env => HasCabalLoader env where-  cabalLoaderL :: Lens' env CabalLoader--data CabalLoader = CabalLoader-  { clCache :: !(IORef (Maybe (PackageCache PackageIndex)))-  , clIndices :: ![PackageIndex]-  -- ^ Information on package indices. This is left biased, meaning that-  -- packages in an earlier index will shadow those in a later index.-  ---  -- Warning: if you override packages in an index vs what's available-  -- upstream, you may correct your compiled snapshots, as different-  -- projects may have different definitions of what pkg-ver means! This-  -- feature is primarily intended for adding local packages, not-  -- overriding. Overriding is better accomplished by adding to your-  -- list of packages.-  ---  -- Note that indices specified in a later config file will override-  -- previous indices, /not/ extend them.-  ---  -- Using an assoc list instead of a Map to keep track of priority-  , clStackRoot :: !(Path Abs Dir)-  -- ^ ~/.stack more often than not-  , clUpdateRef :: !(MVar Bool)-  -- ^ Want to try updating the index once during a single run for missing-  -- package identifiers. We also want to ensure we only update once at a-  -- time. Start at @True@.-  ---  -- TODO: probably makes sense to move this concern into getPackageCaches-  , clConnectionCount :: !Int-  -- ^ How many concurrent connections are allowed when downloading-  , clIgnoreRevisionMismatch :: !Bool-  -- ^ Ignore a revision mismatch when loading up cabal files,-  -- and fall back to the latest revision. See:-  -- <https://github.com/commercialhaskell/stack/issues/3520>-  }---- | Root for a specific package index-configPackageIndexRoot :: HasCabalLoader env => IndexName -> RIO env (Path Abs Dir)-configPackageIndexRoot (IndexName name) = do-    cl <- view cabalLoaderL-    let root = clStackRoot cl-    dir <- parseRelDir $ B8.unpack name-    return (root </> $(mkRelDir "indices") </> dir)---- | Location of the 01-index.tar file-configPackageIndex :: HasCabalLoader env => IndexName -> RIO env (Path Abs File)-configPackageIndex name = (</> $(mkRelFile "01-index.tar")) <$> configPackageIndexRoot name---- | Location of the 01-index.cache file-configPackageIndexCache :: HasCabalLoader env => IndexName -> RIO env (Path Abs File)-configPackageIndexCache name = (</> $(mkRelFile "01-index.cache")) <$> configPackageIndexRoot name---- | Location of the 00-index.cache file-configPackageIndexCacheOld :: HasCabalLoader env => IndexName -> RIO env (Path Abs File)-configPackageIndexCacheOld = liftM (</> $(mkRelFile "00-index.cache")) . configPackageIndexRoot---- | Location of the 00-index.tar file. This file is just a copy of--- the 01-index.tar file, provided for tools which still look for the--- 00-index.tar file.-configPackageIndexOld :: HasCabalLoader env => IndexName -> RIO env (Path Abs File)-configPackageIndexOld = liftM (</> $(mkRelFile "00-index.tar")) . configPackageIndexRoot---- | Location of the 01-index.tar.gz file-configPackageIndexGz :: HasCabalLoader env => IndexName -> RIO env (Path Abs File)-configPackageIndexGz = liftM (</> $(mkRelFile "01-index.tar.gz")) . configPackageIndexRoot----------------- Lifted from cabal-install, Distribution.Client.Tar:--- | Return the number of blocks in an entry.-entrySizeInBlocks :: Tar.Entry -> Int64-entrySizeInBlocks entry = 1 + case Tar.entryContent entry of-  Tar.NormalFile     _   size -> bytesToBlocks size-  Tar.OtherEntryType _ _ size -> bytesToBlocks size-  _                           -> 0-  where-    bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512)
− src/Stack/PackageLocation.hs 
@@ -1,291 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}---- | Deal with downloading, cloning, or whatever else is necessary for--- getting a 'PackageLocation' into something Stack can work with.-module Stack.PackageLocation-  ( resolveSinglePackageLocation-  , resolveMultiPackageLocation-  , parseSingleCabalFile-  , parseSingleCabalFileIndex-  , parseMultiCabalFiles-  , parseMultiCabalFilesIndex-  ) where--import qualified Codec.Archive.Tar as Tar-import qualified Codec.Archive.Zip as Zip-import qualified Codec.Compression.GZip as GZip-import Stack.Prelude-import           Crypto.Hash (hashWith, SHA256(..))-import qualified Data.ByteArray as Mem (convert)-import qualified Data.ByteString as S-import qualified Data.ByteString.Base64.URL as B64URL-import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8, decodeUtf8)-import Distribution.PackageDescription (GenericPackageDescription)-import Network.HTTP.StackClient (parseUrlThrow)-import Network.HTTP.Download.Verified-import Path-import Path.Extra-import Path.IO-import Stack.Package-import Stack.Types.BuildPlan-import Stack.Types.Config-import Stack.Types.PackageIdentifier-import qualified System.Directory as Dir-import RIO.Process---- | Same as 'resolveMultiPackageLocation', but works on a--- 'SinglePackageLocation'.-resolveSinglePackageLocation-    :: HasConfig env-    => Path Abs Dir -- ^ project root-    -> PackageLocation FilePath-    -> RIO env (Path Abs Dir)-resolveSinglePackageLocation projRoot (PLFilePath fp) = resolveDir projRoot fp-resolveSinglePackageLocation projRoot (PLArchive (Archive url subdir msha)) = do-    workDir <- view workDirL--        -- TODO: dedupe with code for snapshot hash?-    let name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 url-        root = projRoot </> workDir </> $(mkRelDir "downloaded")-        fileExtension' = ".http-archive"--    fileRel <- parseRelFile $ name ++ fileExtension'-    dirRel <- parseRelDir name-    dirRelTmp <- parseRelDir $ name ++ ".tmp"-    let fileDownload = root </> fileRel-        dir = root </> dirRel--    exists <- doesDirExist dir-    unless exists $ do-        liftIO $ ignoringAbsence (removeDirRecur dir)--        let dirTmp = root </> dirRelTmp-        liftIO $ ignoringAbsence (removeDirRecur dirTmp)--        urlExists <- liftIO $ Dir.doesFileExist $ T.unpack url-        file <--          if urlExists-            then do-              file <- liftIO $ Dir.canonicalizePath (T.unpack url) >>= parseAbsFile-              case msha of-                Nothing -> return ()-                Just sha -> do-                  actualSha <- mkStaticSHA256FromFile file-                  when (sha /= actualSha) $ error $ concat-                    [ "Invalid SHA256 found for local archive "-                    , show file-                    , "\nExpected: "-                    , T.unpack $ staticSHA256ToText sha-                    , "\nActual:   "-                    , T.unpack $ staticSHA256ToText actualSha-                    ]-              return file-            else do-              req <- parseUrlThrow $ T.unpack url-              let dreq = DownloadRequest-                    { drRequest = req-                    , drHashChecks =-                        case msha of-                          Nothing -> []-                          Just sha ->-                            [HashCheck-                              { hashCheckAlgorithm = SHA256-                              , hashCheckHexDigest = CheckHexDigestByteString $ staticSHA256ToBase16 sha-                              }]-                    , drLengthCheck = Nothing -- TODO add length info?-                    , drRetryPolicy = drRetryPolicyDefault-                    }-              _ <- verifiedDownload dreq fileDownload (const $ return ())-              return fileDownload--        let fp = toFilePath file--        withLazyFile fp $ \lbs -> do-          -- Share a single file read among all of the different-          -- parsing attempts. We're not worried about unbounded-          -- memory usage, as we will detect almost immediately if-          -- this is the wrong type of file.--          let tryTargz = do-                logDebug $ "Trying to ungzip/untar " <> fromString fp-                let entries = Tar.read $ GZip.decompress lbs-                liftIO $ Tar.unpack (toFilePath dirTmp) entries-              tryZip = do-                logDebug $ "Trying to unzip " <> fromString fp-                let archive = Zip.toArchive lbs-                liftIO $  Zip.extractFilesFromArchive [Zip.OptDestination-                                                       (toFilePath dirTmp)] archive-              tryTar = do-                logDebug $ "Trying to untar (no ungzip) " <> fromString fp-                let entries = Tar.read lbs-                liftIO $ Tar.unpack (toFilePath dirTmp) entries-              err = throwM $ UnableToExtractArchive url file--              catchAnyLog goodpath handler =-                  catchAny goodpath $ \e -> do-                      logDebug $ "Got exception: " <> displayShow e-                      handler--          tryTargz `catchAnyLog` tryZip `catchAnyLog` tryTar `catchAnyLog` err-        renameDir dirTmp dir--    x <- listDir dir-    case x of-        ([dir'], []) -> resolveDir dir' subdir-        (dirs, files) -> liftIO $ do-            ignoringAbsence (removeFile fileDownload)-            ignoringAbsence (removeDirRecur dir)-            throwIO $ UnexpectedArchiveContents dirs files-resolveSinglePackageLocation projRoot (PLRepo (Repo url commit repoType' subdir)) =-    cloneRepo projRoot url commit repoType' >>= flip resolveDir subdir---- | Resolve a PackageLocation into a path, downloading and cloning as--- necessary.------ Returns the updated PackageLocation value with just a single subdir--- (if relevant).-resolveMultiPackageLocation-    :: HasConfig env-    => Path Abs Dir -- ^ project root-    -> PackageLocation Subdirs-    -> RIO env [(Path Abs Dir, PackageLocation FilePath)]-resolveMultiPackageLocation y (PLFilePath fp) = do-  dir <- resolveSinglePackageLocation y (PLFilePath fp)-  return [(dir, PLFilePath fp)]-resolveMultiPackageLocation y (PLArchive (Archive url subdirs msha)) = do-  dir <- resolveSinglePackageLocation y (PLArchive (Archive url "." msha))-  let subdirs' =-        case subdirs of-          DefaultSubdirs -> ["."]-          ExplicitSubdirs subs -> subs-  forM subdirs' $ \subdir -> do-    dir' <- resolveDir dir subdir-    return (dir', PLArchive (Archive url subdir msha))-resolveMultiPackageLocation projRoot (PLRepo (Repo url commit repoType' subdirs)) = do-  dir <- cloneRepo projRoot url commit repoType'--  let subdirs' =-        case subdirs of-          DefaultSubdirs -> ["."]-          ExplicitSubdirs subs -> subs-  forM subdirs' $ \subdir -> do-    dir' <- resolveDir dir subdir-    return (dir', PLRepo $ Repo url commit repoType' subdir)--cloneRepo-    :: HasConfig env-    => Path Abs Dir -- ^ project root-    -> Text -- ^ URL-    -> Text -- ^ commit-    -> RepoType-    -> RIO env (Path Abs Dir)-cloneRepo projRoot url commit repoType' = do-    workDir <- view workDirL-    let nameBeforeHashing = case repoType' of-            RepoGit -> T.unwords [url, commit]-            RepoHg -> T.unwords [url, commit, "hg"]-        -- TODO: dedupe with code for snapshot hash?-        name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 nameBeforeHashing-        root = projRoot </> workDir </> $(mkRelDir "downloaded")--    dirRel <- parseRelDir name-    let dir = root </> dirRel--    exists <- doesDirExist dir-    unless exists $ do-        liftIO $ ignoringAbsence (removeDirRecur dir)--        let cloneAndExtract commandName cloneArgs resetCommand =-              withWorkingDir (toFilePath root) $ do-                ensureDir root-                logInfo $ "Cloning " <> display commit <> " from " <> display url-                proc commandName-                       ("clone" :-                        cloneArgs ++-                        [ T.unpack url-                        , toFilePathNoTrailingSep dir-                        ]) runProcess_-                created <- doesDirExist dir-                unless created $ throwM $ FailedToCloneRepo commandName-                withWorkingDir (toFilePath dir) $ readProcessNull commandName-                    (resetCommand ++ [T.unpack commit, "--"])-                    `catchAny` \case-                        ex -> do-                            logInfo $-                              "Please ensure that commit " <>-                              display commit <>-                              " exists within " <>-                              display url-                            throwM ex--        case repoType' of-            RepoGit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"]-            RepoHg  -> cloneAndExtract "hg"  []              ["--repository", ".", "update", "-C"]--    return dir---- | Parse the cabal files present in the given--- 'PackageLocationIndex FilePath'.-parseSingleCabalFileIndex-  :: forall env.-     HasConfig env-  => Path Abs Dir -- ^ project root, used for checking out necessary files-  -> PackageLocationIndex FilePath-  -> RIO env GenericPackageDescription--- Need special handling of PLIndex for efficiency (just read from the--- index tarball) and correctness (get the cabal file from the index,--- not the package tarball itself, yay Hackage revisions).-parseSingleCabalFileIndex _ (PLIndex pir) = readPackageUnresolvedIndex pir-parseSingleCabalFileIndex root (PLOther loc) = lpvGPD <$> parseSingleCabalFile root False loc--parseSingleCabalFile-  :: forall env. HasConfig env-  => Path Abs Dir -- ^ project root, used for checking out necessary files-  -> Bool -- ^ print warnings?-  -> PackageLocation FilePath-  -> RIO env LocalPackageView-parseSingleCabalFile root printWarnings loc = do-  dir <- resolveSinglePackageLocation root loc-  (gpd, cabalfp) <- readPackageUnresolvedDir dir printWarnings-  return LocalPackageView-    { lpvCabalFP = cabalfp-    , lpvGPD = gpd-    , lpvLoc = loc-    }---- | Load and parse cabal files into 'GenericPackageDescription's-parseMultiCabalFiles-  :: forall env. HasConfig env-  => Path Abs Dir -- ^ project root, used for checking out necessary files-  -> Bool -- ^ print warnings?-  -> PackageLocation Subdirs-  -> RIO env [LocalPackageView]-parseMultiCabalFiles root printWarnings loc0 =-  resolveMultiPackageLocation root loc0 >>=-  mapM (\(dir, loc1) -> do-    (gpd, cabalfp) <- readPackageUnresolvedDir dir printWarnings-    return LocalPackageView-      { lpvCabalFP = cabalfp-      , lpvGPD = gpd-      , lpvLoc = loc1-      })---- | 'parseMultiCabalFiles' but supports 'PLIndex'-parseMultiCabalFilesIndex-  :: forall env. HasConfig env-  => Path Abs Dir -- ^ project root, used for checking out necessary files-  -> PackageLocationIndex Subdirs-  -> RIO env [(GenericPackageDescription, PackageLocationIndex FilePath)]-parseMultiCabalFilesIndex _root (PLIndex pir) =-  pure . (, PLIndex pir) <$>-  readPackageUnresolvedIndex pir-parseMultiCabalFilesIndex root (PLOther loc0) =-  map (\lpv -> (lpvGPD lpv, PLOther $ lpvLoc lpv)) <$>-  parseMultiCabalFiles root False loc0
src/Stack/Path.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  -- | Handy path information. module Stack.Path@@ -10,84 +11,81 @@  import           Stack.Prelude import           Data.List (intercalate)-import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T import           Lens.Micro (lens) import qualified Options.Applicative as OA+import           Pantry (HasPantryConfig (..)) import           Path import           Path.Extra import           Stack.Constants import           Stack.Constants.Config import           Stack.GhcPkg as GhcPkg-import           Stack.PackageIndex (HasCabalLoader (..))+import           Stack.Runners import           Stack.Types.Config-import           Stack.Types.Runner import qualified System.FilePath as FP-import           System.IO (stderr)+import           RIO.PrettyPrint import           RIO.Process (HasProcessContext (..), exeSearchPathL)  -- | Print out useful path information in a human-readable format (and -- support others later).-path-    :: HasEnvConfig env-    => [Text]-    -> RIO env ()+path :: [Text] -> RIO Runner () path keys =-    do -- We must use a BuildConfig from an EnvConfig to ensure that it contains the-       -- full environment info including GHC paths etc.-       bc <- view $ envConfigL.buildConfigL-       -- This is the modified 'bin-path',-       -- including the local GHC or MSYS if not configured to operate on-       -- global GHC.-       -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'.-       -- So it's not the *minimal* override path.-       snap <- packageDatabaseDeps-       plocal <- packageDatabaseLocal-       extra <- packageDatabaseExtra-       whichCompiler <- view $ actualCompilerVersionL.whichCompilerL-       global <- GhcPkg.getGlobalDB whichCompiler-       snaproot <- installationRootDeps-       localroot <- installationRootLocal-       toolsDir <- bindirCompilerTools-       distDir <- distRelativeDir-       hpcDir <- hpcReportDir-       compiler <- getCompilerPath whichCompiler-       let deprecated = filter ((`elem` keys) . fst) deprecatedPathKeys-       liftIO $ forM_ deprecated $ \(oldOption, newOption) -> T.hPutStrLn stderr $ T.unlines-           [ ""-           , "'--" <> oldOption <> "' will be removed in a future release."-           , "Please use '--" <> newOption <> "' instead."-           , ""-           ]-       forM_-           -- filter the chosen paths in flags (keys),+    do let deprecated = filter ((`elem` keys) . fst) deprecatedPathKeys+       forM_ deprecated $ \(oldOption, newOption) -> logWarn $+           "\n" <>+           "'--" <> display oldOption <> "' will be removed in a future release.\n" <>+           "Please use '--" <> display newOption <> "' instead.\n" <>+           "\n"+       let -- filter the chosen paths in flags (keys),            -- or show all of them if no specific paths chosen.-           (filter+           goodPaths = filter                 (\(_,key,_) ->                       (null keys && key /= T.pack deprecatedStackRootOptionName) || elem key keys)-                paths)-           (\(_,key,path') ->-                 liftIO $ T.putStrLn-                     -- If a single path type is requested, output it directly.-                     -- Otherwise, name all the paths.-                     ((if length keys == 1-                          then ""-                          else key <> ": ") <>-                      path'-                          (PathInfo-                               bc-                               snap-                               plocal-                               global-                               snaproot-                               localroot-                               toolsDir-                               distDir-                               hpcDir-                               extra-                               compiler)))+                paths+           singlePath = length goodPaths == 1+           toEither (_, k, UseHaddocks p) = Left (k, p)+           toEither (_, k, WithoutHaddocks p) = Right (k, p)+           (with, without) = partitionEithers $ map toEither goodPaths+           printKeys extractors single = do+             pathInfo <- fillPathInfo+             liftIO $ forM_ extractors $ \(key, extractPath) -> do+               let prefix = if single then "" else key <> ": "+               T.putStrLn $ prefix <> extractPath pathInfo+           runHaddock x = local+             (set (globalOptsL.globalOptsBuildOptsMonoidL.buildOptsMonoidHaddockL) (Just x)) .+             withConfig YesReexec . -- FIXME this matches previous behavior, but doesn't make a lot of sense+             withDefaultEnvConfig+       -- MSS 2019-03-17 Not a huge fan of rerunning withConfig and+       -- withDefaultEnvConfig each time, need to figure out what+       -- purpose is served and whether we can achieve it without two+       -- completely separate Config setups+       runHaddock True $ printKeys with singlePath+       runHaddock False $ printKeys without singlePath +fillPathInfo :: HasEnvConfig env => RIO env PathInfo+fillPathInfo = do+     -- We must use a BuildConfig from an EnvConfig to ensure that it contains the+     -- full environment info including GHC paths etc.+     piBuildConfig <- view $ envConfigL.buildConfigL+     -- This is the modified 'bin-path',+     -- including the local GHC or MSYS if not configured to operate on+     -- global GHC.+     -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'.+     -- So it's not the *minimal* override path.+     piSnapDb <- packageDatabaseDeps+     piLocalDb <- packageDatabaseLocal+     piExtraDbs <- packageDatabaseExtra+     piGlobalDb <- view $ compilerPathsL.to cpGlobalDB+     piSnapRoot <- installationRootDeps+     piLocalRoot <- installationRootLocal+     piToolsDir <- bindirCompilerTools+     piHoogleRoot <- hoogleRoot+     piDistDir <- distRelativeDir+     piHpcDir <- hpcReportDir+     piCompiler <- getCompilerPath+     return PathInfo {..}+ pathParser :: OA.Parser [Text] pathParser =     mapMaybeA@@ -100,17 +98,18 @@  -- | Passed to all the path printers as a source of info. data PathInfo = PathInfo-    { piBuildConfig  :: BuildConfig-    , piSnapDb       :: Path Abs Dir-    , piLocalDb      :: Path Abs Dir-    , piGlobalDb     :: Path Abs Dir-    , piSnapRoot     :: Path Abs Dir-    , piLocalRoot    :: Path Abs Dir-    , piToolsDir     :: Path Abs Dir+    { piBuildConfig  :: !BuildConfig+    , piSnapDb       :: !(Path Abs Dir)+    , piLocalDb      :: !(Path Abs Dir)+    , piGlobalDb     :: !(Path Abs Dir)+    , piSnapRoot     :: !(Path Abs Dir)+    , piLocalRoot    :: !(Path Abs Dir)+    , piToolsDir     :: !(Path Abs Dir)+    , piHoogleRoot   :: !(Path Abs Dir)     , piDistDir      :: Path Rel Dir-    , piHpcDir       :: Path Abs Dir-    , piExtraDbs     :: [Path Abs Dir]-    , piCompiler     :: Path Abs File+    , piHpcDir       :: !(Path Abs Dir)+    , piExtraDbs     :: ![Path Abs Dir]+    , piCompiler     :: !(Path Abs File)     }  instance HasPlatform PathInfo@@ -118,15 +117,23 @@     logFuncL = configL.logFuncL instance HasRunner PathInfo where     runnerL = configL.runnerL+instance HasStylesUpdate PathInfo where+  stylesUpdateL = runnerL.stylesUpdateL+instance HasTerm PathInfo where+  useColorL = runnerL.useColorL+  termWidthL = runnerL.termWidthL+instance HasGHCVariant PathInfo instance HasConfig PathInfo-instance HasCabalLoader PathInfo where-    cabalLoaderL = configL.cabalLoaderL+instance HasPantryConfig PathInfo where+    pantryConfigL = configL.pantryConfigL instance HasProcessContext PathInfo where     processContextL = configL.processContextL instance HasBuildConfig PathInfo where     buildConfigL = lens piBuildConfig (\x y -> x { piBuildConfig = y })                  . buildConfigL +data UseHaddocks a = UseHaddocks a | WithoutHaddocks a+ -- | The paths of interest to a user. The first tuple string is used -- for a description that the optparse flag uses, and the second -- string as a machine-readable key and also for @--foo@ flags. The user@@ -136,80 +143,83 @@ -- When printing output we generate @PathInfo@ and pass it to the -- function to generate an appropriate string.  Trailing slashes are -- removed, see #506-paths :: [(String, Text, PathInfo -> Text)]+paths :: [(String, Text, UseHaddocks (PathInfo -> Text))] paths =     [ ( "Global stack root directory"       , T.pack stackRootOptionName-      , view $ stackRootL.to toFilePathNoTrailingSep.to T.pack)+      , WithoutHaddocks $ view (stackRootL.to toFilePathNoTrailingSep.to T.pack))     , ( "Project root (derived from stack.yaml file)"       , "project-root"-      , view $ projectRootL.to toFilePathNoTrailingSep.to T.pack)+      , WithoutHaddocks $ view (projectRootL.to toFilePathNoTrailingSep.to T.pack))     , ( "Configuration location (where the stack.yaml file is)"       , "config-location"-      , view $ stackYamlL.to toFilePath.to T.pack)+      , WithoutHaddocks $ view (stackYamlL.to toFilePath.to T.pack))     , ( "PATH environment variable"       , "bin-path"-      , T.pack . intercalate [FP.searchPathSeparator] . view exeSearchPathL)+      , WithoutHaddocks $ T.pack . intercalate [FP.searchPathSeparator] . view exeSearchPathL)     , ( "Install location for GHC and other core tools"       , "programs"-      , view $ configL.to configLocalPrograms.to toFilePathNoTrailingSep.to T.pack)+      , WithoutHaddocks $ view (configL.to configLocalPrograms.to toFilePathNoTrailingSep.to T.pack))     , ( "Compiler binary (e.g. ghc)"       , "compiler-exe"-      , T.pack . toFilePath . piCompiler )+      , WithoutHaddocks $ T.pack . toFilePath . piCompiler )     , ( "Directory containing the compiler binary (e.g. ghc)"       , "compiler-bin"-      , T.pack . toFilePathNoTrailingSep . parent . piCompiler )+      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . parent . piCompiler )     , ( "Directory containing binaries specific to a particular compiler (e.g. intero)"       , "compiler-tools-bin"-      , T.pack . toFilePathNoTrailingSep . piToolsDir )+      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piToolsDir )     , ( "Local bin dir where stack installs executables (e.g. ~/.local/bin)"       , "local-bin"-      , view $ configL.to configLocalBin.to toFilePathNoTrailingSep.to T.pack)+      , WithoutHaddocks $ view $ configL.to configLocalBin.to toFilePathNoTrailingSep.to T.pack)     , ( "Extra include directories"       , "extra-include-dirs"-      , T.intercalate ", " . map T.pack . Set.elems . configExtraIncludeDirs . view configL )+      , WithoutHaddocks $ T.intercalate ", " . map T.pack . configExtraIncludeDirs . view configL )     , ( "Extra library directories"       , "extra-library-dirs"-      , T.intercalate ", " . map T.pack . Set.elems . configExtraLibDirs . view configL )+      , WithoutHaddocks $ T.intercalate ", " . map T.pack . configExtraLibDirs . view configL )     , ( "Snapshot package database"       , "snapshot-pkg-db"-      , T.pack . toFilePathNoTrailingSep . piSnapDb )+      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piSnapDb )     , ( "Local project package database"       , "local-pkg-db"-      , T.pack . toFilePathNoTrailingSep . piLocalDb )+      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piLocalDb )     , ( "Global package database"       , "global-pkg-db"-      , T.pack . toFilePathNoTrailingSep . piGlobalDb )+      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piGlobalDb )     , ( "GHC_PACKAGE_PATH environment variable"       , "ghc-package-path"-      , \pi' -> mkGhcPackagePath True (piLocalDb pi') (piSnapDb pi') (piExtraDbs pi') (piGlobalDb pi'))+      , WithoutHaddocks $ \pi' -> mkGhcPackagePath True (piLocalDb pi') (piSnapDb pi') (piExtraDbs pi') (piGlobalDb pi'))     , ( "Snapshot installation root"       , "snapshot-install-root"-      , T.pack . toFilePathNoTrailingSep . piSnapRoot )+      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piSnapRoot )     , ( "Local project installation root"       , "local-install-root"-      , T.pack . toFilePathNoTrailingSep . piLocalRoot )+      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piLocalRoot )     , ( "Snapshot documentation root"       , "snapshot-doc-root"-      , \pi' -> T.pack (toFilePathNoTrailingSep (piSnapRoot pi' </> docDirSuffix)))+      , UseHaddocks $ \pi' -> T.pack (toFilePathNoTrailingSep (piSnapRoot pi' </> docDirSuffix)))     , ( "Local project documentation root"       , "local-doc-root"-      , \pi' -> T.pack (toFilePathNoTrailingSep (piLocalRoot pi' </> docDirSuffix)))+      , UseHaddocks $ \pi' -> T.pack (toFilePathNoTrailingSep (piLocalRoot pi' </> docDirSuffix)))+    , ( "Local project documentation root"+      , "local-hoogle-root"+      , UseHaddocks $ T.pack . toFilePathNoTrailingSep . piHoogleRoot)     , ( "Dist work directory, relative to package directory"       , "dist-dir"-      , T.pack . toFilePathNoTrailingSep . piDistDir )+      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piDistDir )     , ( "Where HPC reports and tix files are stored"       , "local-hpc-root"-      , T.pack . toFilePathNoTrailingSep . piHpcDir )+      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . piHpcDir )     , ( "DEPRECATED: Use '--local-bin' instead"       , "local-bin-path"-      , T.pack . toFilePathNoTrailingSep . configLocalBin . view configL )+      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . configLocalBin . view configL )     , ( "DEPRECATED: Use '--programs' instead"       , "ghc-paths"-      , T.pack . toFilePathNoTrailingSep . configLocalPrograms . view configL )+      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . configLocalPrograms . view configL )     , ( "DEPRECATED: Use '--" <> stackRootOptionName <> "' instead"       , T.pack deprecatedStackRootOptionName-      , T.pack . toFilePathNoTrailingSep . view stackRootL )+      , WithoutHaddocks $ T.pack . toFilePathNoTrailingSep . view stackRootL )     ]  deprecatedPathKeys :: [(Text, Text)]
src/Stack/Prelude.hs view
@@ -1,12 +1,8 @@-{-# LANGUAGE CPP                        #-} {-# LANGUAGE NoImplicitPrelude          #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE ScopedTypeVariables        #-} module Stack.Prelude-  ( withSourceFile-  , withSinkFile-  , withSinkFileCautious-  , withSystemTempDir+  ( withSystemTempDir   , withKeepSystemTempDir   , sinkProcessStderrStdout   , sinkProcessStdout@@ -14,73 +10,45 @@   , readProcessNull   , withProcessContext   , stripCR-  , hIsTerminalDeviceOrMinTTY   , prompt   , promptPassword   , promptBool+  , stackProgName+  , FirstTrue (..)+  , fromFirstTrue+  , defaultFirstTrue+  , FirstFalse (..)+  , fromFirstFalse+  , defaultFirstFalse+  , writeBinaryFileAtomic   , module X   ) where  import           RIO                  as X+import           RIO.File             as X import           Data.Conduit         as X (ConduitM, runConduit, (.|)) import           Path                 as X (Abs, Dir, File, Path, Rel,                                             toFilePath)+import           Pantry               as X hiding (Package (..), loadSnapshot)  import           Data.Monoid          as X (First (..), Any (..), Sum (..), Endo (..))  import qualified Path.IO -import qualified System.IO as IO-import qualified System.Directory as Dir-import qualified System.FilePath as FP import           System.IO.Echo (withoutInputEcho)-import           System.IO.Error (isDoesNotExistError) -#ifdef WINDOWS-import           System.Win32 (isMinTTYHandle, withHandleToHANDLE)-#endif--import           Data.Conduit.Binary (sourceHandle, sinkHandle) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL-import           Data.Conduit.Process.Typed (withLoggedProcess_, createSource)+import           Data.Conduit.Process.Typed (withLoggedProcess_, createSource, byteStringInput) import           RIO.Process (HasProcessContext (..), ProcessContext, setStdin, closed, getStderr, getStdout, proc, withProcess_, setStdout, setStderr, ProcessConfig, readProcess_, workingDirL)-import           Data.Store           as X (Store) import           Data.Text.Encoding (decodeUtf8With) import           Data.Text.Encoding.Error (lenientDecode)  import qualified Data.Text.IO as T import qualified RIO.Text as T---- | Get a source for a file. Unlike @sourceFile@, doesn't require--- @ResourceT@. Unlike explicit @withBinaryFile@ and @sourceHandle@--- usage, you can't accidentally use @WriteMode@ instead of--- @ReadMode@.-withSourceFile :: MonadUnliftIO m => FilePath -> (ConduitM i ByteString m () -> m a) -> m a-withSourceFile fp inner = withBinaryFile fp ReadMode $ inner . sourceHandle---- | Same idea as 'withSourceFile', see comments there.-withSinkFile :: MonadUnliftIO m => FilePath -> (ConduitM ByteString o m () -> m a) -> m a-withSinkFile fp inner = withBinaryFile fp WriteMode $ inner . sinkHandle+import System.Permissions (osIsWindows) --- | Like 'withSinkFile', but ensures that the file is atomically--- moved after all contents are written.-withSinkFileCautious-  :: MonadUnliftIO m-  => FilePath-  -> (ConduitM ByteString o m () -> m a)-  -> m a-withSinkFileCautious fp inner =-    withRunInIO $ \run -> bracket acquire cleanup $ \(tmpFP, h) ->-      run (inner $ sinkHandle h) <* (IO.hClose h *> Dir.renameFile tmpFP fp)-  where-    acquire = IO.openBinaryTempFile (FP.takeDirectory fp) (FP.takeFileName fp FP.<.> "tmp")-    cleanup (tmpFP, h) = do-        IO.hClose h-        Dir.removeFile tmpFP `catch` \e ->-            if isDoesNotExistError e-                then return ()-                else throwIO e+import Conduit  -- | Path version withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a@@ -95,7 +63,7 @@  -- | Consume the stdout and stderr of a process feeding strict 'ByteString's to the consumers. ----- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ProcessExitedUnsuccessfully' if the process itself fails.+-- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ExitCodeException' if the process itself fails. sinkProcessStderrStdout   :: forall e o env. (HasProcessContext env, HasLogFunc env, HasCallStack)   => String -- ^ Command@@ -107,6 +75,9 @@   proc name args $ \pc0 -> do     let pc = setStdout createSource            $ setStderr createSource+           -- Don't use closed, since that can break ./configure scripts+           -- See https://github.com/commercialhaskell/stack/pull/4722+           $ setStdin (byteStringInput "")              pc0     withProcess_ pc $ \p ->       runConduit (getStderr p .| sinkStderr) `concurrently`@@ -163,19 +134,6 @@ stripCR :: Text -> Text stripCR = T.dropSuffix "\r" --- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal--- devices, but isMinTTYHandle does.-hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool-#ifdef WINDOWS-hIsTerminalDeviceOrMinTTY h = do-  isTD <- hIsTerminalDevice h-  if isTD-    then return True-    else liftIO $ withHandleToHANDLE h isMinTTYHandle-#else-hIsTerminalDeviceOrMinTTY = hIsTerminalDevice-#endif- -- | Prompt the user by sending text to stdout, and taking a line of -- input from stdin. prompt :: MonadIO m => Text -> m Text@@ -213,3 +171,66 @@     _ -> do       T.putStrLn "Please press either 'y' or 'n', and then enter."       promptBool txt++-- | Name of the 'stack' program.+--+-- NOTE: Should be defined in "Stack.Constants", but not doing so due to the+-- GHC stage restrictions.+stackProgName :: String+stackProgName = "stack"++-- | Like @First Bool@, but the default is @True@.+newtype FirstTrue = FirstTrue { getFirstTrue :: Maybe Bool }+  deriving (Show, Eq, Ord)+instance Semigroup FirstTrue where+  FirstTrue (Just x) <> _ = FirstTrue (Just x)+  FirstTrue Nothing <> x = x+instance Monoid FirstTrue where+  mempty = FirstTrue Nothing+  mappend = (<>)++-- | Get the 'Bool', defaulting to 'True'+fromFirstTrue :: FirstTrue -> Bool+fromFirstTrue = fromMaybe True . getFirstTrue++-- | Helper for filling in default values+defaultFirstTrue :: (a -> FirstTrue) -> Bool+defaultFirstTrue _ = True++-- | Like @First Bool@, but the default is @False@.+newtype FirstFalse = FirstFalse { getFirstFalse :: Maybe Bool }+  deriving (Show, Eq, Ord)+instance Semigroup FirstFalse where+  FirstFalse (Just x) <> _ = FirstFalse (Just x)+  FirstFalse Nothing <> x = x+instance Monoid FirstFalse where+  mempty = FirstFalse Nothing+  mappend = (<>)++-- | Get the 'Bool', defaulting to 'False'+fromFirstFalse :: FirstFalse -> Bool+fromFirstFalse = fromMaybe False . getFirstFalse++-- | Helper for filling in default values+defaultFirstFalse :: (a -> FirstFalse) -> Bool+defaultFirstFalse _ = False++-- | Write a @Builder@ to a file and atomically rename.+--+-- In the future: replace with a function in rio+writeBinaryFileAtomic :: MonadIO m => Path absrel File -> Builder -> m ()+writeBinaryFileAtomic fp builder+  -- Atomic file writing is not supported on Windows yet, unfortunately.+  -- withSinkFileCautious needs to be implemented properly for Windows to make+  -- this work.+  | osIsWindows =+      liftIO $+      withBinaryFile (toFilePath fp) WriteMode $ \h ->+      hPutBuilder h builder+  | otherwise =+      liftIO $+      withSinkFileCautious (toFilePath fp) $ \sink ->+      runConduit $+      yield builder .|+      unsafeBuilderToByteString .|+      sink
− src/Stack/PrettyPrint.hs 
@@ -1,244 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}--module Stack.PrettyPrint-    (-      -- * Pretty printing functions-      displayPlain, displayWithColor-      -- * Logging based on pretty-print typeclass-    , prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent-    , prettyDebugL, prettyInfoL, prettyNoteL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL-    , prettyDebugS, prettyInfoS, prettyNoteS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS-      -- * Semantic styling functions-      -- | These are preferred to styling or colors directly, so that we can-      -- encourage consistency.-    , styleWarning, styleError, styleGood-    , styleShell, styleFile, styleUrl, styleDir, styleModule-    , styleCurrent, styleTarget-    , styleRecommendation-    , displayMilliseconds-      -- * Formatting utils-    , bulletedList-    , spacedBulletedList-    , debugBracket-      -- * Re-exports from "Text.PrettyPrint.Leijen.Extended"-    , Display(..), AnsiDoc, AnsiAnn(..), HasAnsiAnn(..), Doc-    , nest, line, linebreak, group, softline, softbreak-    , align, hang, indent, encloseSep-    , (<+>)-    , hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate-    , fill, fillBreak-    , enclose, squotes, dquotes, parens, angles, braces, brackets-    , indentAfterLabel, wordDocs, flow-    ) where--import qualified RIO-import           Stack.Prelude hiding (Display (..))-import           Data.List (intersperse)-import qualified Data.Text as T-import qualified Distribution.ModuleName as C (ModuleName)-import qualified Distribution.Text as C (display)-import           Stack.Types.NamedComponent-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Runner-import           Stack.Types.Version-import           Text.PrettyPrint.Leijen.Extended--displayWithColor-    :: (HasRunner env, Display a, HasAnsiAnn (Ann a),-        MonadReader env m, HasLogFunc env, HasCallStack)-    => a -> m T.Text-displayWithColor x = do-    useAnsi <- view useColorL-    termWidth <- view $ runnerL.to runnerTermWidth-    return $ (if useAnsi then displayAnsi else displayPlain) termWidth x---- TODO: switch to using implicit callstacks once 7.8 support is dropped--prettyWith :: (HasRunner env, HasCallStack, Display b, HasAnsiAnn (Ann b),-               MonadReader env m, MonadIO m)-           => LogLevel -> (a -> b) -> a -> m ()-prettyWith level f = logGeneric "" level . RIO.display <=< displayWithColor . f---- Note: I think keeping this section aligned helps spot errors, might be--- worth keeping the alignment in place.--prettyDebugWith, prettyInfoWith, prettyNoteWith, prettyWarnWith, prettyErrorWith, prettyWarnNoIndentWith, prettyErrorNoIndentWith-  :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m)-  => (a -> Doc AnsiAnn) -> a -> m ()-prettyDebugWith = prettyWith LevelDebug-prettyInfoWith  = prettyWith LevelInfo-prettyNoteWith f  = prettyWith LevelInfo-                          ((line <>) . (styleGood "Note:" <+>) .-                           indentAfterLabel . f)-prettyWarnWith f  = prettyWith LevelWarn-                          ((line <>) . (styleWarning "Warning:" <+>) .-                           indentAfterLabel . f)-prettyErrorWith f = prettyWith LevelError-                          ((line <>) . (styleError   "Error:" <+>) .-                           indentAfterLabel . f)-prettyWarnNoIndentWith f  = prettyWith LevelWarn-                                  ((line <>) . (styleWarning "Warning:" <+>) . f)-prettyErrorNoIndentWith f = prettyWith LevelError-                                  ((line <>) . (styleError   "Error:" <+>) . f)--prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent-  :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m)-  => Doc AnsiAnn -> m ()-prettyDebug         = prettyDebugWith         id-prettyInfo          = prettyInfoWith          id-prettyNote          = prettyNoteWith          id-prettyWarn          = prettyWarnWith          id-prettyError         = prettyErrorWith         id-prettyWarnNoIndent  = prettyWarnNoIndentWith  id-prettyErrorNoIndent = prettyErrorNoIndentWith id--prettyDebugL, prettyInfoL, prettyNoteL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL-  :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m)-  => [Doc AnsiAnn] -> m ()-prettyDebugL         = prettyDebugWith         fillSep-prettyInfoL          = prettyInfoWith          fillSep-prettyNoteL          = prettyNoteWith          fillSep-prettyWarnL          = prettyWarnWith          fillSep-prettyErrorL         = prettyErrorWith         fillSep-prettyWarnNoIndentL  = prettyWarnNoIndentWith  fillSep-prettyErrorNoIndentL = prettyErrorNoIndentWith fillSep--prettyDebugS, prettyInfoS, prettyNoteS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS-  :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m)-  => String -> m ()-prettyDebugS         = prettyDebugWith         flow-prettyInfoS          = prettyInfoWith          flow-prettyNoteS          = prettyNoteWith          flow-prettyWarnS          = prettyWarnWith          flow-prettyErrorS         = prettyErrorWith         flow-prettyWarnNoIndentS  = prettyWarnNoIndentWith  flow-prettyErrorNoIndentS = prettyErrorNoIndentWith flow---- End of aligned section---- | Use after a label and before the rest of what's being labelled for---   consistent spacing/indenting/etc.------   For example this is used after "Warning:" in warning messages.-indentAfterLabel :: Doc a -> Doc a-indentAfterLabel = align---- | Make a 'Doc' from each word in a 'String'-wordDocs :: String -> [Doc a]-wordDocs = map fromString . words---- | Wordwrap a 'String'-flow :: String -> Doc a-flow = fillSep . wordDocs--debugBracket :: (HasCallStack, HasRunner env, MonadReader env m,-                 MonadIO m, MonadUnliftIO m) => Doc AnsiAnn -> m a -> m a-debugBracket msg f = do-  let output = logDebug . RIO.display <=< displayWithColor-  output $ "Start: " <> msg-  start <- getMonotonicTime-  x <- f `catch` \ex -> do-      end <- getMonotonicTime-      let diff = end - start-      output $ "Finished with exception in" <+> displayMilliseconds diff <> ":" <+>-          msg <> line <>-          "Exception thrown: " <> fromString (show ex)-      throwIO (ex :: SomeException)-  end <- getMonotonicTime-  let diff = end - start-  output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg-  return x----   The following syles do not affect the colour of the background.---- | Style an 'AnsiDoc' as an error. Should be used sparingly, not to style---   entire long messages. For example, it's used to style the "Error:"---   label for an error message, not the entire message.-styleError :: AnsiDoc -> AnsiDoc-styleError = dullred---- | Style an 'AnsiDoc' as a warning. Should be used sparingly, not to style---   entire long messages. For example, it's used to style the "Warning:"---   label for an error message, not the entire message.-styleWarning :: AnsiDoc -> AnsiDoc-styleWarning = dullyellow---- | Style an 'AnsiDoc' in a way to emphasize that it is a particularly good---   thing.-styleGood :: AnsiDoc -> AnsiDoc-styleGood = green---- | Style an 'AnsiDoc' as a shell command, i.e. when suggesting something---   to the user that should be typed in directly as written.-styleShell :: AnsiDoc -> AnsiDoc-styleShell = magenta---- | Style an 'AnsiDoc' as a filename. See 'styleDir' for directories.-styleFile :: AnsiDoc -> AnsiDoc-styleFile = dullcyan---- | Style an 'AsciDoc' as a URL.  For now using the same style as files.-styleUrl :: AnsiDoc -> AnsiDoc-styleUrl = styleFile---- | Style an 'AnsiDoc' as a directory name. See 'styleFile' for files.-styleDir :: AnsiDoc -> AnsiDoc-styleDir = bold . blue---- | Style used to highlight part of a recommended course of action.-styleRecommendation :: AnsiDoc -> AnsiDoc-styleRecommendation = bold . green---- | Style an 'AnsiDoc' in a way that emphasizes that it is related to---   a current thing. For example, could be used when talking about the---   current package we're processing when outputting the name of it.-styleCurrent :: AnsiDoc -> AnsiDoc-styleCurrent = dullyellow---- TODO: figure out how to describe this-styleTarget :: AnsiDoc -> AnsiDoc-styleTarget = cyan---- | Style an 'AnsiDoc' as a module name-styleModule :: AnsiDoc -> AnsiDoc-styleModule = magenta -- TODO: what color should this be?--instance Display PackageName where-    display = fromString . packageNameString--instance Display PackageIdentifier where-    display = fromString . packageIdentifierString--instance Display Version where-    display = fromString . versionString--instance Display (Path b File) where-    display = styleFile . fromString . toFilePath--instance Display (Path b Dir) where-    display = styleDir . fromString . toFilePath--instance Display (PackageName, NamedComponent) where-    display = cyan . fromString . T.unpack . renderPkgComponent--instance Display C.ModuleName where-    display = fromString . C.display---- Display milliseconds.-displayMilliseconds :: Double -> AnsiDoc-displayMilliseconds t = green $-    fromString (show (round (t * 1000) :: Int)) <> "ms"---- | Display a bulleted list of 'AnsiDoc'.-bulletedList :: [AnsiDoc] -> AnsiDoc-bulletedList = mconcat . intersperse line . map (("*" <+>) . align)---- | Display a bulleted list of 'AnsiDoc' with a blank line between--- each.-spacedBulletedList :: [AnsiDoc] -> AnsiDoc-spacedBulletedList = mconcat . intersperse (line <> line) . map (("*" <+>) . align)
src/Stack/Runners.hs view
@@ -2,247 +2,208 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}  -- | Utilities for running stack commands.+--+-- Instead of using Has-style classes below, the type signatures use+-- concrete environments to try and avoid accidentally rerunning+-- configuration parsing. For example, we want @withConfig $+-- withConfig $ ...@ to fail. module Stack.Runners-    ( withGlobalConfigAndLock-    , withConfigAndLock-    , withMiniConfigAndLock-    , withBuildConfigAndLock-    , withBuildConfigAndLockNoDocker-    , withBuildConfig-    , withBuildConfigExt-    , withBuildConfigDot-    , loadConfigWithOpts-    , loadCompilerVersion-    , withUserFileLock-    , munlockFile+    ( withBuildConfig+    , withEnvConfig+    , withDefaultEnvConfig+    , withConfig+    , withGlobalProject+    , withRunnerGlobal+    , ShouldReexec (..)     ) where  import           Stack.Prelude-import           Path-import           Path.IO+import           RIO.Process (mkDefaultProcessContext)+import           RIO.Time (addUTCTime, getCurrentTime)+import           Stack.Build.Target(NeedTargets(..)) import           Stack.Config+import           Stack.Constants+import           Stack.DefaultColorWhen (defaultColorWhen) import qualified Stack.Docker as Docker import qualified Stack.Nix as Nix import           Stack.Setup-import           Stack.Types.Compiler (CompilerVersion, CVType (..))+import           Stack.Storage (upgradeChecksSince, logUpgradeCheck) import           Stack.Types.Config-import           Stack.Types.Runner-import           System.Environment (getEnvironment)-import           System.IO-import           System.FileLock-import           Stack.Dot+import           Stack.Types.Docker (dockerEnable)+import           Stack.Types.Nix (nixEnable)+import           Stack.Types.Version (stackMinorVersion, stackVersion, minorVersion)+import           System.Console.ANSI (hSupportsANSIWithoutEmulation)+import           System.Console.Terminal.Size (size, width) --- FIXME it seems wrong that we call lcLoadBuildConfig multiple times-loadCompilerVersion :: GlobalOpts-                    -> LoadConfig-                    -> IO (CompilerVersion 'CVWanted)-loadCompilerVersion go lc =-    view wantedCompilerVersionL <$> lcLoadBuildConfig lc (globalCompiler go)+-- | Ensure that no project settings are used when running 'withConfig'.+withGlobalProject :: RIO Runner a -> RIO Runner a+withGlobalProject inner = do+  oldSYL <- view stackYamlLocL+  case oldSYL of+    SYLDefault -> local (set stackYamlLocL SYLGlobalProject) inner+    _ -> throwString "Cannot use this command with options which override the stack.yaml location" --- | Enforce mutual exclusion of every action running via this--- function, on this path, on this users account.+-- | Helper for 'withEnvConfig' which passes in some default arguments: ----- A lock file is created inside the given directory.  Currently,--- stack uses locks per-snapshot.  In the future, stack may refine--- this to an even more fine-grain locking approach.+-- * No targets are requested ---withUserFileLock :: MonadUnliftIO m-                 => GlobalOpts-                 -> Path Abs Dir-                 -> (Maybe FileLock -> m a)-                 -> m a-withUserFileLock go@GlobalOpts{} dir act = do-    env <- liftIO getEnvironment-    let toLock = lookup "STACK_LOCK" env == Just "true"-    if toLock-        then do-            let lockfile = $(mkRelFile "lockfile")-            let pth = dir </> lockfile-            ensureDir dir-            -- Just in case of asynchronous exceptions, we need to be careful-            -- when using tryLockFile here:-            bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive)-                    (maybe (return ()) (liftIO . unlockFile))-                    (\fstTry ->-                        case fstTry of-                          Just lk -> finally (act $ Just lk) (liftIO $ unlockFile lk)-                          Nothing ->-                            do let chatter = globalLogLevel go /= LevelOther "silent"-                               when chatter $-                                 liftIO $ hPutStrLn stderr $ "Failed to grab lock ("++show pth++-                                                     "); other stack instance running.  Waiting..."-                               bracket (liftIO $ lockFile (toFilePath pth) Exclusive)-                                       (liftIO . unlockFile)-                                       (\lk -> do-                                            when chatter $-                                              liftIO $ hPutStrLn stderr "Lock acquired, proceeding."-                                            act $ Just lk))-        else act Nothing--withConfigAndLock-    :: GlobalOpts-    -> RIO Config ()-    -> IO ()-withConfigAndLock go@GlobalOpts{..} inner = loadConfigWithOpts go $ \lc -> do-    withUserFileLock go (view stackRootL lc) $ \lk ->-        runRIO (lcConfig lc) $-            Docker.reexecWithOptionalContainer-                (lcProjectRoot lc)-                Nothing-                (runRIO (lcConfig lc) inner)-                Nothing-                (Just $ munlockFile lk)---- | Loads global config, ignoring any configuration which would be--- loaded due to $PWD.-withGlobalConfigAndLock-    :: GlobalOpts-    -> RIO Config ()-    -> IO ()-withGlobalConfigAndLock go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do-    lc <- runRIO runner $-        loadConfigMaybeProject-            globalConfigMonoid-            Nothing-            LCSNoProject-    withUserFileLock go (view stackRootL lc) $ \_lk ->-        runRIO (lcConfig lc) inner---- For now the non-locking version just unlocks immediately.--- That is, there's still a serialization point.-withBuildConfig-    :: GlobalOpts-    -> RIO EnvConfig ()-    -> IO ()-withBuildConfig go inner =-    withBuildConfigAndLock go (\lk -> do munlockFile lk-                                         inner)--withBuildConfigAndLock-    :: GlobalOpts-    -> (Maybe FileLock -> RIO EnvConfig ())-    -> IO ()-withBuildConfigAndLock go inner =-    withBuildConfigExt False go Nothing inner Nothing+-- * Default command line build options are assumed+withDefaultEnvConfig+    :: RIO EnvConfig a+    -> RIO Config a+withDefaultEnvConfig = withEnvConfig AllowNoTargets defaultBuildOptsCLI --- | See issue #2010 for why this exists. Currently just used for the--- specific case of "stack clean --full".-withBuildConfigAndLockNoDocker-    :: GlobalOpts-    -> (Maybe FileLock -> RIO EnvConfig ())-    -> IO ()-withBuildConfigAndLockNoDocker go inner =-    withBuildConfigExt True go Nothing inner Nothing+-- | Upgrade a 'Config' environment to a 'BuildConfig' environment by+-- performing further parsing of project-specific configuration. This+-- is intended to be run inside a call to 'withConfig'.+withBuildConfig :: RIO BuildConfig a -> RIO Config a+withBuildConfig inner = do+  bconfig <- loadBuildConfig+  runRIO bconfig inner -withBuildConfigExt-    :: Bool-    -> GlobalOpts-    -> Maybe (RIO Config ())-    -- ^ Action to perform before the build.  This will be run on the host-    -- OS even if Docker is enabled for builds.  The build config is not-    -- available in this action, since that would require build tools to be-    -- installed on the host OS.-    -> (Maybe FileLock -> RIO EnvConfig ())+-- | Upgrade a 'Config' environment to an 'EnvConfig' environment by+-- performing further parsing of project-specific configuration (like+-- 'withBuildConfig') and then setting up a build environment+-- toolchain. This is intended to be run inside a call to+-- 'withConfig'.+withEnvConfig+    :: NeedTargets+    -> BuildOptsCLI+    -> RIO EnvConfig a     -- ^ Action that uses the build config.  If Docker is enabled for builds,     -- this will be run in a Docker container.-    -> Maybe (RIO Config ())-    -- ^ Action to perform after the build.  This will be run on the host-    -- OS even if Docker is enabled for builds.  The build config is not-    -- available in this action, since that would require build tools to be-    -- installed on the host OS.-    -> IO ()-withBuildConfigExt skipDocker go@GlobalOpts{..} mbefore inner mafter = loadConfigWithOpts go $ \lc -> do-    withUserFileLock go (view stackRootL lc) $ \lk0 -> do-      -- A local bit of state for communication between callbacks:-      curLk <- newIORef lk0-      let inner' lk =-            -- Locking policy:  This is only used for build commands, which-            -- only need to lock the snapshot, not the global lock.  We-            -- trade in the lock here.-            do dir <- installationRootDeps-               -- Hand-over-hand locking:-               withUserFileLock go dir $ \lk2 -> do-                 liftIO $ writeIORef curLk lk2-                 liftIO $ munlockFile lk-                 logDebug "Starting to execute command inside EnvConfig"-                 inner lk2--      let inner'' lk = do-              bconfig <- lcLoadBuildConfig lc globalCompiler-              envConfig <- runRIO bconfig (setupEnv Nothing)-              runRIO envConfig (inner' lk)+    -> RIO Config a+withEnvConfig needTargets boptsCLI inner =+  withBuildConfig $ do+    envConfig <- setupEnv needTargets boptsCLI Nothing+    logDebug "Starting to execute command inside EnvConfig"+    runRIO envConfig inner -      let getCompilerVersion = loadCompilerVersion go lc-      if skipDocker-          then runRIO (lcConfig lc) $ do-              forM_ mbefore id-              Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (inner'' lk0)-              forM_ mafter id-          else runRIO (lcConfig lc) $-              Docker.reexecWithOptionalContainer-                       (lcProjectRoot lc)-                       mbefore-                       (runRIO (lcConfig lc) $-                          Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (inner'' lk0))-                       mafter-                       (Just $ liftIO $-                            do lk' <- readIORef curLk-                               munlockFile lk')+-- | If the settings justify it, should we reexec inside Docker or Nix?+data ShouldReexec = YesReexec | NoReexec  -- | Load the configuration. Convenience function used -- throughout this module.-loadConfigWithOpts-  :: GlobalOpts-  -> (LoadConfig -> IO a)-  -> IO a-loadConfigWithOpts go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do-    mstackYaml <- forM globalStackYaml resolveFile'-    runRIO runner $ 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-        -- happen ASAP but needs a configuration.-        forM_ globalDockerEntrypoint $ Docker.entrypoint (lcConfig lc)-        liftIO $ inner lc+withConfig+  :: ShouldReexec+  -> RIO Config a+  -> RIO Runner a+withConfig shouldReexec inner =+    loadConfig $ \config -> do+      -- If we have been relaunched in a Docker container, perform in-container initialization+      -- (switch UID, etc.).  We do this after first loading the configuration since it must+      -- happen ASAP but needs a configuration.+      view (globalOptsL.to globalDockerEntrypoint) >>=+        traverse_ (Docker.entrypoint config)+      runRIO config $ do+        -- Catching all exceptions here, since we don't want this+        -- check to ever cause Stack to stop working+        shouldUpgradeCheck `catchAny` \e ->+          logError ("Error when running shouldUpgradeCheck: " <> displayShow e)+        case shouldReexec of+          YesReexec -> reexec inner+          NoReexec -> inner -withRunnerGlobal :: GlobalOpts -> (Runner -> IO a) -> IO a-withRunnerGlobal GlobalOpts{..} = withRunner-  globalLogLevel-  globalTimeInLog-  globalTerminal-  globalColorWhen-  globalTermWidth-  (isJust globalReExecVersion)+-- | Perform a Docker or Nix reexec, if warranted. Otherwise run the+-- inner action.+reexec :: RIO Config a -> RIO Config a+reexec inner = do+  nixEnable' <- asks $ nixEnable . configNix+  dockerEnable' <- asks $ dockerEnable . configDocker+  case (nixEnable', dockerEnable') of+    (True, True) -> throwString "Cannot use both Docker and Nix at the same time"+    (False, False) -> inner -withMiniConfigAndLock-    :: GlobalOpts-    -> RIO MiniConfig ()-    -> IO ()-withMiniConfigAndLock go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do-    miniConfig <--        runRIO runner $-        loadMiniConfig . lcConfig <$>-        loadConfigMaybeProject-          globalConfigMonoid-          globalResolver-          LCSNoProject-    runRIO miniConfig inner+    -- Want to use Nix+    (True, False) -> do+      whenM getInContainer $ throwString "Cannot use Nix from within a Docker container"+      inShell <- getInNixShell+      if inShell+        then do+          isReexec <- view reExecL+          if isReexec+            then inner+            else throwString "In Nix shell but reExecL is False"+        else Nix.runShellAndExit --- | Unlock a lock file, if the value is Just-munlockFile :: MonadIO m => Maybe FileLock -> m ()-munlockFile Nothing = return ()-munlockFile (Just lk) = liftIO $ unlockFile lk+    -- Want to use Docker+    (False, True) -> do+      whenM getInNixShell $ throwString "Cannot use Docker from within a Nix shell"+      inContainer <- getInContainer+      if inContainer+        then do+          isReexec <- view reExecL+          if isReexec+            then inner+            else throwIO Docker.OnlyOnHostException+        else Docker.runContainerAndExit --- Plumbing for --test and --bench flags-withBuildConfigDot :: DotOpts -> GlobalOpts -> RIO EnvConfig () -> IO ()-withBuildConfigDot opts go f = withBuildConfig go' f-  where-    go' =-        (if dotTestTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) else id) $-        (if dotBenchTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) else id)-        go+-- | Use the 'GlobalOpts' to create a 'Runner' and run the provided+-- action.+withRunnerGlobal :: GlobalOpts -> RIO Runner a -> IO a+withRunnerGlobal go inner = do+  colorWhen <-+    case getFirst $ configMonoidColorWhen $ globalConfigMonoid go of+      Nothing -> defaultColorWhen+      Just colorWhen -> pure colorWhen+  useColor <- case colorWhen of+    ColorNever -> return False+    ColorAlways -> return True+    ColorAuto -> fromMaybe True <$>+                          hSupportsANSIWithoutEmulation stderr+  termWidth <- clipWidth <$> maybe (fromMaybe defaultTerminalWidth+                                    <$> fmap (fmap width) size)+                                   pure (globalTermWidth go)+  menv <- mkDefaultProcessContext+  logOptions0 <- logOptionsHandle stderr False+  let logOptions+        = setLogUseColor useColor+        $ setLogUseTime (globalTimeInLog go)+        $ setLogMinLevel (globalLogLevel go)+        $ setLogVerboseFormat (globalLogLevel go <= LevelDebug)+        $ setLogTerminal (globalTerminal go)+          logOptions0+  withLogFunc logOptions $ \logFunc -> runRIO Runner+    { runnerGlobalOpts = go+    , runnerUseColor = useColor+    , runnerLogFunc = logFunc+    , runnerTermWidth = termWidth+    , runnerProcessContext = menv+    } inner+  where clipWidth w+          | w < minTerminalWidth = minTerminalWidth+          | w > maxTerminalWidth = maxTerminalWidth+          | otherwise = w +-- | Check if we should recommend upgrading Stack and, if so, recommend it.+shouldUpgradeCheck :: RIO Config ()+shouldUpgradeCheck = do+  config <- ask+  when (configRecommendUpgrade config) $ do+    now <- getCurrentTime+    let yesterday = addUTCTime (-24 * 60 * 60) now+    checks <- upgradeChecksSince yesterday+    when (checks == 0) $ do+      mversion <- getLatestHackageVersion NoRequireHackageIndex "stack" UsePreferredVersions+      case mversion of+        -- Compare the minor version so we avoid patch-level, Hackage-only releases.+        -- See: https://github.com/commercialhaskell/stack/pull/4729#pullrequestreview-227176315+        Just (PackageIdentifierRevision _ version _) | minorVersion version > stackMinorVersion -> do+          logWarn "<<<<<<<<<<<<<<<<<<"+          logWarn $+            "You are currently using Stack version " <>+            fromString (versionString stackVersion) <>+            ", but version " <>+            fromString (versionString version) <>+            " is available"+          logWarn "You can try to upgrade by running 'stack upgrade'"+          logWarn $+            "Tired of seeing this? Add 'recommend-stack-upgrade: false' to " <>+            fromString (toFilePath (configUserConfigPath config))+          logWarn ">>>>>>>>>>>>>>>>>>"+          logWarn ""+          logWarn ""+        _ -> pure ()+      logUpgradeCheck now
src/Stack/SDist.hs view
@@ -42,28 +42,21 @@ import qualified Distribution.PackageDescription.Parsec as Cabal import           Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) import qualified Distribution.Types.UnqualComponentName as Cabal-import qualified Distribution.Text as Cabal import           Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion, hasUpperBound, hasLowerBound) import           Lens.Micro (set) import           Path import           Path.IO hiding (getModificationTime, getPermissions, withSystemTempDir)-import qualified RIO+import           RIO.PrettyPrint import           Stack.Build (mkBaseConfigOpts, build) import           Stack.Build.Execute import           Stack.Build.Installed-import           Stack.Build.Source (loadSourceMap)-import           Stack.Build.Target hiding (PackageType (..))-import           Stack.PackageLocation (resolveMultiPackageLocation)-import           Stack.PrettyPrint-import           Stack.Constants+import           Stack.Build.Source (projectLocalPackages) import           Stack.Package+import           Stack.SourceMap import           Stack.Types.Build-import           Stack.Types.BuildPlan import           Stack.Types.Config import           Stack.Types.Package-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Runner+import           Stack.Types.SourceMap import           Stack.Types.Version import           System.Directory (getModificationTime, getPermissions) import qualified System.FilePath as FP@@ -78,10 +71,6 @@   -- ^ PVP Bounds overrides   , sdoptsIgnoreCheck :: Bool   -- ^ Whether to ignore check of the package for common errors-  , sdoptsSign :: Bool-  -- ^ Whether to sign the package-  , sdoptsSignServerUrl :: String-  -- ^ The URL of the signature server   , sdoptsBuildTarball :: Bool   -- ^ Whether to build the tarball   , sdoptsTarPath :: Maybe FilePath@@ -117,8 +106,9 @@         tweakCabal = pvpBounds /= PvpBoundsNone         pkgFp = toFilePath pkgDir     lp <- readLocalPackage pkgDir+    sourceMap <- view $ envConfigL.to envConfigSourceMap     logInfo $ "Getting file list for " <> fromString pkgFp-    (fileList, cabalfp) <-  getSDistFileList lp+    (fileList, cabalfp) <- getSDistFileList lp     logInfo $ "Building sdist tarball for " <> fromString pkgFp     files <- normalizeTarballPaths (map (T.unpack . stripCR . T.pack) (lines fileList)) @@ -145,13 +135,13 @@             -- This is a cabal file, we're going to tweak it, but only             -- tweak it as a revision.             | tweakCabal && isCabalFp fp && asRevision = do-                lbsIdent <- getCabalLbs pvpBounds (Just 1) cabalfp+                lbsIdent <- getCabalLbs pvpBounds (Just 1) cabalfp sourceMap                 liftIO (writeIORef cabalFileRevisionRef (Just lbsIdent))                 packWith packFileEntry False fp             -- Same, except we'll include the cabal file in the             -- original tarball upload.             | tweakCabal && isCabalFp fp = do-                (_ident, lbs) <- getCabalLbs pvpBounds Nothing cabalfp+                (_ident, lbs) <- getCabalLbs pvpBounds Nothing cabalfp sourceMap                 currTime <- liftIO getPOSIXTime -- Seconds from UNIX epoch                 tp <- liftIO $ tarPath False fp                 return $ (Tar.fileEntry tp lbs) { Tar.entryTime = floor currTime }@@ -169,22 +159,19 @@             => PvpBoundsType             -> Maybe Int -- ^ optional revision             -> Path Abs File -- ^ cabal file+            -> SourceMap             -> RIO env (PackageIdentifier, L.ByteString)-getCabalLbs pvpBounds mrev cabalfp = do-    (gpd, cabalfp') <- readPackageUnresolvedDir (parent cabalfp) False+getCabalLbs pvpBounds mrev cabalfp sourceMap = do+    (gpdio, _name, cabalfp') <- loadCabalFilePath (parent cabalfp)+    gpd <- liftIO $ gpdio NoPrintWarnings     unless (cabalfp == cabalfp')       $ error $ "getCabalLbs: cabalfp /= cabalfp': " ++ show (cabalfp, cabalfp')-    (_, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI-    (installedMap, _, _, _) <- getInstalled GetInstalledOpts-                                { getInstalledProfiling = False-                                , getInstalledHaddock = False-                                , getInstalledSymbols = False-                                }-                                sourceMap+    installMap <- toInstallMap sourceMap+    (installedMap, _, _, _) <- getInstalled installMap     let internalPackages = Set.fromList $           gpdPackageName gpd :-          map (fromCabalPackageName . Cabal.unqualComponentNameToPackageName . fst) (Cabal.condSubLibraries gpd)-        gpd' = gtraverseT (addBounds internalPackages sourceMap installedMap) gpd+          map (Cabal.unqualComponentNameToPackageName . fst) (Cabal.condSubLibraries gpd)+        gpd' = gtraverseT (addBounds internalPackages installMap installedMap) gpd         gpd'' =           case mrev of             Nothing -> gpd'@@ -198,7 +185,7 @@                   $ Cabal.packageDescription gpd'                   }               }-    ident <- parsePackageIdentifierFromString $ Cabal.display $ Cabal.package $ Cabal.packageDescription gpd''+        ident = Cabal.package $ Cabal.packageDescription gpd''     -- Sanity rendering and reparsing the input, to ensure there are no     -- cabal bugs, since there have been bugs here before, and currently     -- are at the time of writing:@@ -208,7 +195,7 @@     -- https://github.com/haskell/cabal/issues/4863 (current issue)     let roundtripErrs =           [ flow "Bug detected in Cabal library. ((parse . render . parse) === id) does not hold for the cabal file at"-          <+> display cabalfp+          <+> pretty cabalfp           , ""           ]         (_warnings, eres) = Cabal.runParseResult@@ -223,19 +210,19 @@             prettyWarn $ vsep $ roundtripErrs ++               [ "This seems to be fixed in development versions of Cabal, but at time of writing, the fix is not in any released versions."               , ""-              ,  "Please see this GitHub issue for status:" <+> styleUrl "https://github.com/commercialhaskell/stack/issues/3549"+              ,  "Please see this GitHub issue for status:" <+> style Url "https://github.com/commercialhaskell/stack/issues/3549"               , ""               , fillSep                 [ flow "If the issue is closed as resolved, then you may be able to fix this by upgrading to a newer version of stack via"-                , styleShell "stack upgrade"+                , style Shell "stack upgrade"                 , flow "for latest stable version or"-                , styleShell "stack upgrade --git"+                , style Shell "stack upgrade --git"                 , flow "for the latest development version."                 ]               , ""               , fillSep                 [ flow "If the issue is fixed, but updating doesn't solve the problem, please check if there are similar open issues, and if not, report a new issue to the stack issue tracker, at"-                , styleUrl "https://github.com/commercialhaskell/stack/issues/new"+                , style Url "https://github.com/commercialhaskell/stack/issues/new"                 ]               , ""               , flow "If the issue is not fixed, feel free to leave a comment on it indicating that you would like it to be fixed."@@ -245,8 +232,8 @@         prettyWarn $ vsep $ roundtripErrs ++           [ flow "In particular, parsing the rendered cabal file is yielding a parse error.  Please check if there are already issues tracking this, and if not, please report new issues to the stack and cabal issue trackers, via"           , bulletedList-            [ styleUrl "https://github.com/commercialhaskell/stack/issues/new"-            , styleUrl "https://github.com/haskell/cabal/issues/new"+            [ style Url "https://github.com/commercialhaskell/stack/issues/new"+            , style Url "https://github.com/haskell/cabal/issues/new"             ]           , flow $ "The parse error is: " ++ unlines (map show errs)           , ""@@ -256,30 +243,28 @@       , TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd''       )   where-    addBounds :: Set PackageName -> SourceMap -> InstalledMap -> Dependency -> Dependency-    addBounds internalPackages sourceMap installedMap dep@(Dependency cname range) =+    addBounds :: Set PackageName -> InstallMap -> InstalledMap -> Dependency -> Dependency+    addBounds internalPackages installMap installedMap dep@(Dependency name range) =       if name `Set.member` internalPackages         then dep         else case foundVersion of           Nothing -> dep-          Just version -> Dependency cname $ simplifyVersionRange+          Just version -> Dependency name $ simplifyVersionRange             $ (if toAddUpper && not (hasUpperBound range) then addUpper version else id)             $ (if toAddLower && not (hasLowerBound range) then addLower version else id)               range       where-        name = fromCabalPackageName cname         foundVersion =-          case Map.lookup name sourceMap of-              Just ps -> Just (piiVersion ps)+          case Map.lookup name installMap of+              Just (_, version) -> Just version               Nothing ->                   case Map.lookup name installedMap of                       Just (_, installed) -> Just (installedVersion installed)                       Nothing -> Nothing      addUpper version = intersectVersionRanges-        (earlierVersion $ toCabalVersion $ nextMajorVersion version)-    addLower version = intersectVersionRanges-        (orLaterVersion (toCabalVersion version))+        (earlierVersion $ nextMajorVersion version)+    addLower version = intersectVersionRanges (orLaterVersion version)      (toAddLower, toAddUpper) =       case pvpBounds of@@ -301,24 +286,25 @@ readLocalPackage :: HasEnvConfig env => Path Abs Dir -> RIO env LocalPackage readLocalPackage pkgDir = do     config  <- getDefaultPackageConfig-    (package, cabalfp) <- readPackageDir config pkgDir True+    (gpdio, _, cabalfp) <- loadCabalFilePath pkgDir+    gpd <- liftIO $ gpdio YesPrintWarnings+    let package = resolvePackage config gpd     return LocalPackage         { lpPackage = package         , lpWanted = False -- HACK: makes it so that sdist output goes to a log instead of a file.-        , lpDir = pkgDir         , lpCabalFile = cabalfp         -- NOTE: these aren't the 'correct values, but aren't used in         -- the usage of this function in this module.         , lpTestDeps = Map.empty         , lpBenchDeps = Map.empty         , lpTestBench = Nothing+        , lpBuildHaddocks = False         , lpForceDirty = False-        , lpDirtyFiles = Nothing-        , lpNewBuildCaches = Map.empty-        , lpComponentFiles = Map.empty+        , lpDirtyFiles = pure Nothing+        , lpNewBuildCaches = pure Map.empty+        , lpComponentFiles = pure Map.empty         , lpComponents = Set.empty         , lpUnbuildable = Set.empty-        , lpLocation = PLFilePath $ toFilePath pkgDir         }  -- | Returns a newline-separate list of paths, and the absolute path to the .cabal file.@@ -328,13 +314,13 @@         let bopts = defaultBuildOpts         let boptsCli = defaultBuildOptsCLI         baseConfigOpts <- mkBaseConfigOpts boptsCli-        (locals, _) <- loadSourceMap NeedTargets boptsCli+        locals <- projectLocalPackages         withExecuteEnv bopts boptsCli baseConfigOpts locals-            [] [] [] -- provide empty list of globals. This is a hack around custom Setup.hs files+            [] [] [] Nothing -- provide empty list of globals. This is a hack around custom Setup.hs files             $ \ee ->             withSingleContext ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _outputType -> do                 let outFile = toFilePath tmpdir FP.</> "source-files-list"-                cabal KeepTHLoading ["sdist", "--list-sources", outFile]+                cabal CloseOnException KeepTHLoading ["sdist", "--list-sources", outFile]                 contents <- liftIO (S.readFile outFile)                 return (T.unpack $ T.decodeUtf8With T.lenientDecode contents, cabalfp)   where@@ -342,14 +328,15 @@     ac = ActionContext Set.empty [] ConcurrencyAllowed     task = Task         { taskProvides = PackageIdentifier (packageName package) (packageVersion package)-        , taskType = TTFiles lp Local+        , taskType = TTLocalMutable lp         , taskConfigOpts = TaskConfigOpts             { tcoMissing = Set.empty             , tcoOpts = \_ -> ConfigureOpts [] []             }+        , taskBuildHaddock = False         , taskPresent = Map.empty         , taskAllInOne = True-        , taskCachePkgSrc = CacheSrcLocal (toFilePath (lpDir lp))+        , taskCachePkgSrc = CacheSrcLocal (toFilePath (parent $ lpCabalFile lp))         , taskAnyMissing = True         , taskBuildTypeConfig = False         }@@ -396,7 +383,10 @@     pkgDir  <- (pkgDir' </>) `liftM`         (parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball)     --               ^ drop ".tar"     ^ drop ".gz"-    when (sdoptsBuildTarball opts) (buildExtractedTarball pkgDir)+    when (sdoptsBuildTarball opts) (buildExtractedTarball ResolvedPath+                                      { resolvedRelative = RelFilePath "this-is-not-used" -- ugly hack+                                      , resolvedAbsolute = pkgDir+                                      })     unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir)  checkPackageInExtractedTarball@@ -404,12 +394,12 @@   => Path Abs Dir -- ^ Absolute path to tarball   -> RIO env () checkPackageInExtractedTarball pkgDir = do-    (gpd, _cabalfp) <- readPackageUnresolvedDir pkgDir True-    let name = gpdPackageName gpd+    (gpdio, name, _cabalfp) <- loadCabalFilePath pkgDir+    gpd <- liftIO $ gpdio YesPrintWarnings     config  <- getDefaultPackageConfig-    (gdesc, PackageDescriptionPair pkgDesc _) <- readPackageDescriptionDir config pkgDir False+    let PackageDescriptionPair pkgDesc _ = resolvePackageDescription config gpd     logInfo $-        "Checking package '" <> RIO.display name <> "' for common mistakes"+        "Checking package '" <> fromString (packageNameString name) <> "' for common mistakes"     let pkgChecks =           -- MSS 2017-12-12: Try out a few different variants of           -- pkgDesc to try and provoke an error or warning. I don't@@ -421,8 +411,8 @@           -- does. In any event, using `Nothing` seems more logical           -- for this check anyway, and the fallback to `Just pkgDesc`           -- is just a crazy sanity check.-          case Check.checkPackage gdesc Nothing of-            [] -> Check.checkPackage gdesc (Just pkgDesc)+          case Check.checkPackage gpd Nothing of+            [] -> Check.checkPackage gpd (Just pkgDesc)             x -> x     fileChecks <- liftIO $ Check.checkPackageFiles minBound pkgDesc (toFilePath pkgDir)     let checks = pkgChecks ++ fileChecks@@ -438,36 +428,32 @@         Nothing -> return ()         Just ne -> throwM $ CheckException ne -buildExtractedTarball :: HasEnvConfig env => Path Abs Dir -> RIO env ()+buildExtractedTarball :: HasEnvConfig env => ResolvedPath Dir -> RIO env () buildExtractedTarball pkgDir = do-  projectRoot <- view projectRootL   envConfig <- view envConfigL-  localPackageToBuild <- readLocalPackage pkgDir-  let packageEntries = bcPackages (envConfigBuildConfig envConfig)-      getPaths = resolveMultiPackageLocation projectRoot-  allPackagePaths <- fmap (map fst . mconcat) (mapM getPaths packageEntries)+  localPackageToBuild <- readLocalPackage $ resolvedAbsolute pkgDir   -- We remove the path based on the name of the package   let isPathToRemove path = do         localPackage <- readLocalPackage path         return $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild)-  pathsToKeep <- filterM (fmap not . isPathToRemove) allPackagePaths-  newPackagesRef <- liftIO (newIORef Nothing)+  pathsToKeep+    <- fmap Map.fromList+     $ flip filterM (Map.toList (smwProject (bcSMWanted (envConfigBuildConfig envConfig))))+     $ fmap not . isPathToRemove . resolvedAbsolute . ppResolvedDir . snd+  pp <- mkProjectPackage YesPrintWarnings pkgDir False   let adjustEnvForBuild env =         let updatedEnvConfig = envConfig-              {envConfigPackagesRef = newPackagesRef-              ,envConfigBuildConfig = updatePackageInBuildConfig (envConfigBuildConfig envConfig)+              { envConfigSourceMap = updatePackagesInSourceMap (envConfigSourceMap envConfig)+              , envConfigBuildConfig = updateBuildConfig (envConfigBuildConfig envConfig)               }+            updateBuildConfig bc = bc+              { bcConfig = (bcConfig bc)+                 { configBuild = defaultBuildOpts { boptsTests = True } }+              }         in set envConfigL updatedEnvConfig env-      updatePackageInBuildConfig buildConfig = buildConfig-        { bcPackages = map (PLFilePath . toFilePath) $ pkgDir : pathsToKeep-        , bcConfig = (bcConfig buildConfig)-                     { configBuild = defaultBuildOpts-                       { boptsTests = True-                       }-                     }-        }-  local adjustEnvForBuild $-    build (const (return ())) Nothing defaultBuildOptsCLI+      updatePackagesInSourceMap sm =+        sm {smProject = Map.insert (cpName $ ppCommon pp) pp pathsToKeep}+  local adjustEnvForBuild $ build Nothing  -- | Version of 'checkSDistTarball' that first saves lazy bytestring to -- temporary directory and then calls 'checkSDistTarball' on it.@@ -525,6 +511,7 @@     , packageConfigEnableBenchmarks = False     , packageConfigFlags = mempty     , packageConfigGhcOptions = []+    , packageConfigCabalConfigOpts = []     , packageConfigCompilerVersion = compilerVersion     , packageConfigPlatform = platform     }
src/Stack/Script.hs view
@@ -1,70 +1,116 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE RecordWildCards   #-} module Stack.Script     ( scriptCmd     ) where  import           Stack.Prelude+import           Data.ByteString.Builder    (toLazyByteString) import qualified Data.ByteString.Char8      as S8 import qualified Data.Conduit.List          as CL import           Data.List.Split            (splitWhen) import qualified Data.Map.Strict            as Map import qualified Data.Set                   as Set+import           Distribution.Compiler      (CompilerFlavor (..))+import           Distribution.ModuleName    (ModuleName)+import qualified Distribution.PackageDescription as PD+import qualified Distribution.Types.CondTree as C+import           Distribution.Types.PackageName (mkPackageName)+import           Distribution.Types.VersionRange (withinRange)+import           Distribution.System        (Platform (..))+import qualified Pantry.SHA256 as SHA256 import           Path import           Path.IO import qualified Stack.Build+import           Stack.Build.Installed import           Stack.Constants            (osIsWindows)-import           Stack.GhcPkg               (ghcPkgExeName)+import           Stack.PackageDump import           Stack.Options.ScriptParser import           Stack.Runners-import           Stack.Types.BuildPlan+import           Stack.Setup                (withNewLocalBuildTargets)+import           Stack.SourceMap            (getCompilerInfo, immutableLocSha) import           Stack.Types.Compiler import           Stack.Types.Config-import           Stack.Types.PackageName+import           Stack.Types.SourceMap import           System.FilePath            (dropExtension, replaceExtension)+import qualified RIO.Directory as Dir import           RIO.Process+import qualified RIO.Text as T +data StackScriptException+    = MutableDependenciesForScript [PackageName]+    | AmbiguousModuleName ModuleName [PackageName]+  deriving Typeable++instance Exception StackScriptException++instance Show StackScriptException where+    show (MutableDependenciesForScript names) = unlines+        $ "No mutable packages are allowed in the `script` command. Mutable packages found:"+        : map (\name -> "- " ++ packageNameString name) names+    show (AmbiguousModuleName mname pkgs) = unlines+        $ ("Module " ++ moduleNameString mname ++ " appears in multiple packages: ")+        : [unwords $ map packageNameString pkgs ]+ -- | Run a Stack Script-scriptCmd :: ScriptOpts -> GlobalOpts -> IO ()-scriptCmd opts go' = do+scriptCmd :: ScriptOpts -> RIO Runner ()+scriptCmd opts = do+    -- Some warnings in case the user somehow tries to set a+    -- stack.yaml location. Note that in this functions we use+    -- logError instead of logWarn because, when using the+    -- interpreter mode, only error messages are shown. See:+    -- https://github.com/commercialhaskell/stack/issues/3007+    view (globalOptsL.to globalStackYaml) >>= \case+      SYLOverride fp -> logError $+        "Ignoring override stack.yaml file for script command: " <>+        fromString (toFilePath fp)+      SYLGlobalProject -> logError "Ignoring SYLGlobalProject for script command"+      SYLDefault -> return ()+      SYLNoProject _ -> assert False (return ())+     file <- resolveFile' $ soFile opts-    let go = go'-            { globalConfigMonoid = (globalConfigMonoid go')-                { configMonoidInstallGHC = First $ Just True+    let scriptDir = parent file+        modifyGO go = go+            { globalConfigMonoid = (globalConfigMonoid go)+                { configMonoidInstallGHC = FirstTrue $ Just True                 }-            , globalStackYaml = SYLNoConfig $ parent file+            , globalStackYaml = SYLNoProject $ soScriptExtraDeps opts             }-    withBuildConfigAndLock go $ \lk -> do-      -- Some warnings in case the user somehow tries to set a-      -- stack.yaml location. Note that in this functions we use-      -- logError instead of logWarn because, when using the-      -- interpreter mode, only error messages are shown. See:-      -- https://github.com/commercialhaskell/stack/issues/3007-      case globalStackYaml go' of-        SYLOverride fp -> logError $-          "Ignoring override stack.yaml file for script command: " <>-          fromString fp-        SYLDefault -> return ()-        SYLNoConfig _ -> assert False (return ()) +    -- Optimization: if we're compiling, and the executable is newer+    -- than the source file, run it immediately.+    local (over globalOptsL modifyGO) $+      case soCompile opts of+        SEInterpret -> longWay file scriptDir+        SECompile -> shortCut file scriptDir+        SEOptimize -> shortCut file scriptDir++  where+  shortCut file scriptDir = handleIO (const $ longWay file scriptDir) $ do+    srcMod <- getModificationTime file+    exeMod <- Dir.getModificationTime $ toExeName $ toFilePath file+    if srcMod < exeMod+      then exec (toExeName $ toFilePath file) (soArgs opts)+      else longWay file scriptDir++  longWay file scriptDir =+    withConfig YesReexec $+    withDefaultEnvConfig $ do       config <- view configL       menv <- liftIO $ configProcessContextSettings config defaultEnvSettings       withProcessContext menv $ do-        wc <- view $ actualCompilerVersionL.whichCompilerL         colorFlag <- appropriateGhcColorFlag          targetsSet <-             case soPackages opts of                 [] -> do                     -- Using the import parser-                    moduleInfo <- view $ loadedSnapshotL.to toModuleInfo-                    getPackagesFromModuleInfo moduleInfo (soFile opts)+                    getPackagesFromImports (soFile opts)                 packages -> do                     let targets = concatMap wordsComma packages-                    targets' <- mapM parsePackageNameFromString targets+                    targets' <- mapM parsePackageNameThrowing targets                     return $ Set.fromList targets'          unless (Set.null targetsSet) $ do@@ -72,8 +118,8 @@             -- --simple-output to check which packages are installed             -- already. If all needed packages are available, we can             -- skip the (rather expensive) build call below.-            bss <- sinkProcessStdout-                (ghcPkgExeName wc)+            GhcPkgExe pkg <- view $ compilerPathsL.to cpPkg+            bss <- sinkProcessStdout (toFilePath pkg)                 ["list", "--simple-output"] CL.consume -- FIXME use the package info from envConfigPackages, or is that crazy?             let installed = Set.fromList                           $ map toPackageName@@ -84,12 +130,12 @@                 then logDebug "All packages already installed"                 else do                     logDebug "Missing packages, performing installation"-                    Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI-                        { boptsCLITargets = map packageNameText $ Set.toList targetsSet-                        }+                    let targets = map (T.pack . packageNameString) $ Set.toList targetsSet+                    withNewLocalBuildTargets targets $ Stack.Build.build Nothing          let ghcArgs = concat-                [ ["-hide-all-packages"]+                [ ["-i", "-i" ++ toFilePath scriptDir]+                , ["-hide-all-packages"]                 , maybeToList colorFlag                 , map (\x -> "-package" ++ x)                     $ Set.toList@@ -99,61 +145,127 @@                     SEInterpret -> []                     SECompile -> []                     SEOptimize -> ["-O2"]-                , map (\x -> "--ghc-arg=" ++ x) (soGhcOptions opts)+                , soGhcOptions opts                 ]-        munlockFile lk -- Unlock before transferring control away.         case soCompile opts of-          SEInterpret -> exec ("run" ++ compilerExeName wc)+          SEInterpret -> do+            interpret <- view $ compilerPathsL.to cpInterpreter+            exec (toFilePath interpret)                 (ghcArgs ++ toFilePath file : soArgs opts)           _ -> do-            let dir = parent file             -- Use readProcessStdout_ so that (1) if GHC does send any output             -- to stdout, we capture it and stop it from being sent to our             -- stdout, which could break scripts, and (2) if there's an             -- exception, the standard output we did capture will be reported             -- to the user.-            withWorkingDir (toFilePath dir) $ proc-              (compilerExeName wc)+            compilerExeName <- view $ compilerPathsL.to cpCompiler.to toFilePath+            withWorkingDir (toFilePath scriptDir) $ proc+              compilerExeName               (ghcArgs ++ [toFilePath file])               (void . readProcessStdout_)             exec (toExeName $ toFilePath file) (soArgs opts)-  where-    toPackageName = reverse . drop 1 . dropWhile (/= '-') . reverse -    -- Like words, but splits on both commas and spaces-    wordsComma = splitWhen (\c -> c == ' ' || c == ',')+  toPackageName = reverse . drop 1 . dropWhile (/= '-') . reverse -    toExeName fp =-      if osIsWindows-        then replaceExtension fp "exe"-        else dropExtension fp+  -- Like words, but splits on both commas and spaces+  wordsComma = splitWhen (\c -> c == ' ' || c == ',') -getPackagesFromModuleInfo-  :: ModuleInfo-  -> FilePath -- ^ script filename+  toExeName fp =+    if osIsWindows+      then replaceExtension fp "exe"+      else dropExtension fp++getPackagesFromImports+  :: FilePath -- ^ script filename   -> RIO EnvConfig (Set PackageName)-getPackagesFromModuleInfo mi scriptFP = do-    (pns1, mns) <- liftIO $ parseImports <$> S8.readFile scriptFP-    pns2 <--        if Set.null mns-            then return Set.empty-            else do-                pns <- forM (Set.toList mns) $ \mn ->-                    case Map.lookup mn $ miModules mi of-                        Just pns ->-                            case Set.toList pns of-                                [] -> assert False $ return Set.empty-                                [pn] -> return $ Set.singleton pn-                                pns' -> throwString $ concat-                                    [ "Module "-                                    , S8.unpack $ unModuleName mn-                                    , " appears in multiple packages: "-                                    , unwords $ map packageNameString pns'-                                    ]-                        Nothing -> return Set.empty-                return $ Set.unions pns `Set.difference` blacklist-    return $ Set.union pns1 pns2+getPackagesFromImports scriptFP = do+    (pns, mns) <- liftIO $ parseImports <$> S8.readFile scriptFP+    if Set.null mns+        then return pns+        else Set.union pns <$> getPackagesFromModuleNames mns +getPackagesFromModuleNames+  :: Set ModuleName+  -> RIO EnvConfig (Set PackageName)+getPackagesFromModuleNames mns = do+    hash <- hashSnapshot+    withSnapshotCache hash mapSnapshotPackageModules $ \getModulePackages -> do+        pns <- forM (Set.toList mns) $ \mn -> do+            pkgs <- getModulePackages mn+            case pkgs of+                [] -> return Set.empty+                [pn] -> return $ Set.singleton pn+                _ -> throwM $ AmbiguousModuleName mn pkgs+        return $ Set.unions pns `Set.difference` blacklist++hashSnapshot :: RIO EnvConfig SnapshotCacheHash+hashSnapshot = do+    sourceMap <- view $ envConfigL . to envConfigSourceMap+    compilerInfo <- getCompilerInfo+    let eitherPliHash (pn, dep) | PLImmutable pli <- dpLocation dep =+                                    Right $ immutableLocSha pli+                                | otherwise =+                                    Left pn+        deps = Map.toList (smDeps sourceMap)+    case partitionEithers (map eitherPliHash deps) of+        ([], pliHashes) -> do+            let hashedContent = mconcat $ compilerInfo : pliHashes+            pure $ SnapshotCacheHash (SHA256.hashLazyBytes $ toLazyByteString hashedContent)+        (mutables, _) ->+            throwM $ MutableDependenciesForScript mutables++mapSnapshotPackageModules :: RIO EnvConfig (Map PackageName (Set ModuleName))+mapSnapshotPackageModules = do+    sourceMap <- view $ envConfigL . to envConfigSourceMap+    installMap <- toInstallMap sourceMap+    (_installedMap, globalDumpPkgs, snapshotDumpPkgs, _localDumpPkgs) <-+        getInstalled installMap+    let globals = dumpedPackageModules (smGlobal sourceMap) globalDumpPkgs+        notHidden = Map.filter (not . dpHidden)+        notHiddenDeps = notHidden $ smDeps sourceMap+        installedDeps = dumpedPackageModules notHiddenDeps snapshotDumpPkgs+        dumpPkgs = Set.fromList $ map (pkgName . dpPackageIdent) snapshotDumpPkgs+        notInstalledDeps = Map.withoutKeys notHiddenDeps dumpPkgs+    otherDeps <- for notInstalledDeps $ \dep -> do+        gpd <- liftIO $ cpGPD (dpCommon dep)+        Set.fromList <$> allExposedModules gpd+    -- source map construction process should guarantee unique package names+    -- in these maps+    return $ globals <> installedDeps <> otherDeps++dumpedPackageModules :: Map PackageName a+                     -> [DumpPackage]+                     -> Map PackageName (Set ModuleName)+dumpedPackageModules pkgs dumpPkgs =+    let pnames = Map.keysSet pkgs `Set.difference` blacklist+    in Map.fromList+           [ (pn, dpExposedModules)+           | DumpPackage {..} <- dumpPkgs+           , let PackageIdentifier pn _ = dpPackageIdent+           , pn `Set.member` pnames+           ]++allExposedModules :: PD.GenericPackageDescription -> RIO EnvConfig [ModuleName]+allExposedModules gpd = do+  Platform curArch curOs <- view platformL+  curCompiler <- view actualCompilerVersionL+  let checkCond (PD.OS os) = pure $ os == curOs+      checkCond (PD.Arch arch) = pure $ arch == curArch+      checkCond (PD.Impl compiler range) = case curCompiler of+        ACGhc version ->+          pure $ compiler == GHC && version `withinRange` range+        ACGhcGit {} ->+          pure $ compiler == GHC+        ACGhcjs version _ghcVersion ->+          pure $ compiler == GHCJS && version `withinRange` range+      -- currently we don't do flag checking here+      checkCond other = Left other+      mlibrary = snd . C.simplifyCondTree checkCond <$> PD.condLibrary gpd+  pure $ case mlibrary  of+    Just lib -> PD.exposedModules lib +++                map PD.moduleReexportName (PD.reexportedModules lib)+    Nothing  -> mempty+ -- | The Stackage project introduced the concept of hidden packages, -- to deal with conflicting module names. However, this is a -- relatively recent addition (at time of writing). See:@@ -162,65 +274,50 @@ -- packages that should never be auto-parsed in. blacklist :: Set PackageName blacklist = Set.fromList-    [ $(mkPackageName "async-dejafu")-    , $(mkPackageName "monads-tf")-    , $(mkPackageName "crypto-api")-    , $(mkPackageName "fay-base")-    , $(mkPackageName "hashmap")-    , $(mkPackageName "hxt-unicode")-    , $(mkPackageName "hledger-web")-    , $(mkPackageName "plot-gtk3")-    , $(mkPackageName "gtk3")-    , $(mkPackageName "regex-pcre-builtin")-    , $(mkPackageName "regex-compat-tdfa")-    , $(mkPackageName "log")-    , $(mkPackageName "zip")-    , $(mkPackageName "monad-extras")-    , $(mkPackageName "control-monad-free")-    , $(mkPackageName "prompt")-    , $(mkPackageName "kawhi")-    , $(mkPackageName "language-c")-    , $(mkPackageName "gl")-    , $(mkPackageName "svg-tree")-    , $(mkPackageName "Glob")-    , $(mkPackageName "nanospec")-    , $(mkPackageName "HTF")-    , $(mkPackageName "courier")-    , $(mkPackageName "newtype-generics")-    , $(mkPackageName "objective")-    , $(mkPackageName "binary-ieee754")-    , $(mkPackageName "rerebase")-    , $(mkPackageName "cipher-aes")-    , $(mkPackageName "cipher-blowfish")-    , $(mkPackageName "cipher-camellia")-    , $(mkPackageName "cipher-des")-    , $(mkPackageName "cipher-rc4")-    , $(mkPackageName "crypto-cipher-types")-    , $(mkPackageName "crypto-numbers")-    , $(mkPackageName "crypto-pubkey")-    , $(mkPackageName "crypto-random")-    , $(mkPackageName "cryptohash")-    , $(mkPackageName "cryptohash-conduit")-    , $(mkPackageName "cryptohash-md5")-    , $(mkPackageName "cryptohash-sha1")-    , $(mkPackageName "cryptohash-sha256")+    [ mkPackageName "async-dejafu"+    , mkPackageName "monads-tf"+    , mkPackageName "crypto-api"+    , mkPackageName "fay-base"+    , mkPackageName "hashmap"+    , mkPackageName "hxt-unicode"+    , mkPackageName "hledger-web"+    , mkPackageName "plot-gtk3"+    , mkPackageName "gtk3"+    , mkPackageName "regex-pcre-builtin"+    , mkPackageName "regex-compat-tdfa"+    , mkPackageName "log"+    , mkPackageName "zip"+    , mkPackageName "monad-extras"+    , mkPackageName "control-monad-free"+    , mkPackageName "prompt"+    , mkPackageName "kawhi"+    , mkPackageName "language-c"+    , mkPackageName "gl"+    , mkPackageName "svg-tree"+    , mkPackageName "Glob"+    , mkPackageName "nanospec"+    , mkPackageName "HTF"+    , mkPackageName "courier"+    , mkPackageName "newtype-generics"+    , mkPackageName "objective"+    , mkPackageName "binary-ieee754"+    , mkPackageName "rerebase"+    , mkPackageName "cipher-aes"+    , mkPackageName "cipher-blowfish"+    , mkPackageName "cipher-camellia"+    , mkPackageName "cipher-des"+    , mkPackageName "cipher-rc4"+    , mkPackageName "crypto-cipher-types"+    , mkPackageName "crypto-numbers"+    , mkPackageName "crypto-pubkey"+    , mkPackageName "crypto-random"+    , mkPackageName "cryptohash"+    , mkPackageName "cryptohash-conduit"+    , mkPackageName "cryptohash-md5"+    , mkPackageName "cryptohash-sha1"+    , mkPackageName "cryptohash-sha256"     ] -toModuleInfo :: LoadedSnapshot -> ModuleInfo-toModuleInfo ls =-      mconcat-    $ map (\(pn, lpi) ->-            ModuleInfo-            $ Map.fromList-            $ map (, Set.singleton pn)-            $ Set.toList-            $ lpiExposedModules lpi)-    $ filter (\(pn, lpi) ->-            not (lpiHide lpi) &&-            pn `Set.notMember` blacklist)-    $ Map.toList-    $ Map.union (void <$> lsPackages ls) (void <$> lsGlobals ls)- parseImports :: ByteString -> (Set PackageName, Set ModuleName) parseImports =     fold . mapMaybe (parseLine . stripCR') . S8.lines@@ -242,11 +339,13 @@             bs3 = fromMaybe bs2 $ stripPrefix "qualified " bs2         case stripPrefix "\"" bs3 of             Just bs4 -> do-                pn <- parsePackageNameFromString $ S8.unpack $ S8.takeWhile (/= '"') bs4+                pn <- parsePackageNameThrowing $ S8.unpack $ S8.takeWhile (/= '"') bs4                 Just (Set.singleton pn, Set.empty)             Nothing -> Just                 ( Set.empty                 , Set.singleton-                    $ ModuleName+                    $ fromString+                    $ T.unpack+                    $ decodeUtf8With lenientDecode                     $ S8.takeWhile (\c -> c /= ' ' && c /= '(') bs3                 )
src/Stack/Setup.hs view
@@ -1,2032 +1,2099 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-} -- ghc < 7.10-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE CPP #-}--module Stack.Setup-  ( setupEnv-  , ensureCompiler-  , ensureDockerStackExe-  , getSystemCompiler-  , getCabalInstallVersion-  , SetupOpts (..)-  , defaultSetupInfoYaml-  , removeHaskellEnvVars--  -- * Stack binary download-  , StackReleaseInfo-  , getDownloadVersion-  , stackVersion-  , preferredPlatforms-  , downloadStackReleaseInfo-  , downloadStackExe-  ) where--import qualified    Codec.Archive.Tar as Tar-import              Control.Applicative (empty)-import              Control.Monad.State (get, put, modify)-import "cryptonite" Crypto.Hash (SHA1(..), SHA256(..))-import              Data.Aeson.Extended-import qualified    Data.ByteString as S-import qualified    Data.ByteString.Lazy as LBS-import qualified    Data.ByteString.Lazy.Char8 as BL8-import              Data.Char (isSpace)-import              Data.Conduit (await, yield, awaitForever)-import qualified    Data.Conduit.Binary as CB-import              Data.Conduit.Lazy (lazyConsume)-import              Data.Conduit.Lift (evalStateC)-import qualified    Data.Conduit.List as CL-import              Data.Conduit.Process.Typed (eceStderr)-import              Data.Conduit.Zlib          (ungzip)-import              Data.Foldable (maximumBy)-import qualified    Data.HashMap.Strict as HashMap-import              Data.IORef.RunOnce (runOnce)-import              Data.List hiding (concat, elem, maximumBy, any)-import qualified    Data.Map as Map-import qualified    Data.Set as Set-import qualified    Data.Text as T-import qualified    Data.Text.Encoding as T-import qualified    Data.Text.Encoding.Error as T-import              Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)-import qualified    Data.Yaml as Yaml-import              Distribution.System (OS, Arch (..), Platform (..))-import qualified    Distribution.System as Cabal-import              Distribution.Text (simpleParse)-import              Lens.Micro (set)-import              Network.HTTP.StackClient (getResponseBody, getResponseStatusCode)-import              Network.HTTP.Download-import              Path-import              Path.CheckInstall (warnInstallSearchPathIssues)-import              Path.Extra (toFilePathNoTrailingSep)-import              Path.IO hiding (findExecutable, withSystemTempDir)-import              Prelude (until)-import qualified    RIO-import              Stack.Build (build)-import              Stack.Config (loadConfig)-import              Stack.Constants (stackProgName)-import              Stack.Constants.Config (distRelativeDir)-import              Stack.Fetch-import              Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar)-import              Stack.Prelude hiding (Display (..))-import              Stack.PrettyPrint-import              Stack.Setup.Installed-import              Stack.Snapshot (loadSnapshot)-import              Stack.Types.Build-import              Stack.Types.Compiler-import              Stack.Types.CompilerBuild-import              Stack.Types.Config-import              Stack.Types.Docker-import              Stack.Types.PackageIdentifier-import              Stack.Types.PackageName-import              Stack.Types.Runner-import              Stack.Types.Version-import qualified    System.Directory as D-import              System.Environment (getExecutablePath, lookupEnv)-import              System.Exit (ExitCode (..), exitFailure)-import              System.IO.Error (isPermissionError)-import              System.FilePath (searchPathSeparator)-import qualified    System.FilePath as FP-import              RIO.Process-import              Text.Printf (printf)--#if !WINDOWS-import              Bindings.Uname (uname, release)-import              Data.List.Split (splitOn)-import              Foreign.C (throwErrnoIfMinus1_, peekCString)-import              Foreign.Marshal (alloca)-import              System.Posix.Files (setFileMode)-#endif---- | Default location of the stack-setup.yaml file-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 'CVWanted)-    , soptsCompilerCheck :: !VersionCheck-    , soptsStackYaml :: !(Maybe (Path Abs File))-    -- ^ If we got the desired GHC version from that file-    , soptsForceReinstall :: !Bool-    , soptsSanityCheck :: !Bool-    -- ^ Run a sanity check on the selected GHC-    , soptsSkipGhcCheck :: !Bool-    -- ^ Don't check for a compatible GHC version/architecture-    , soptsSkipMsys :: !Bool-    -- ^ Do not use a custom msys installation on Windows-    , soptsUpgradeCabal :: !(Maybe UpgradeTo)-    -- ^ Upgrade the global Cabal library in the database to the newest-    -- version. Only works reliably with a stack-managed installation.-    , soptsResolveMissingGHC :: !(Maybe Text)-    -- ^ Message shown to user for how to resolve the missing GHC-    , soptsSetupInfoYaml :: !FilePath-    -- ^ Location of the main stack-setup.yaml file-    , soptsGHCBindistURL :: !(Maybe String)-    -- ^ Alternate GHC binary distribution (requires custom GHCVariant)-    , soptsGHCJSBootOpts :: [String]-    -- ^ Additional ghcjs-boot options, the default is "--clean"-    }-    deriving Show-data SetupException = UnsupportedSetupCombo OS Arch-                    | MissingDependencies [String]-                    | UnknownCompilerVersion (Set.Set Text) (CompilerVersion 'CVWanted) (Set.Set (CompilerVersion 'CVActual))-                    | UnknownOSKey Text-                    | GHCSanityCheckCompileFailed SomeException (Path Abs File)-                    | WantedMustBeGHC-                    | RequireCustomGHCVariant-                    | ProblemWhileDecompressing (Path Abs File)-                    | SetupInfoMissingSevenz-                    | GHCJSRequiresStandardVariant-                    | GHCJSNotBooted-                    | DockerStackExeNotFound Version Text-                    | UnsupportedSetupConfiguration-    deriving Typeable-instance Exception SetupException-instance Show SetupException where-    show (UnsupportedSetupCombo os arch) = concat-        [ "I don't know how to install GHC for "-        , show (os, arch)-        , ", please install manually"-        ]-    show (MissingDependencies tools) =-        "The following executables are missing and must be installed: " ++-        intercalate ", " tools-    show (UnknownCompilerVersion oskeys wanted known) = concat-        [ "No setup information found for "-        , compilerVersionString wanted-        , " on your platform.\nThis probably means a GHC bindist has not yet been added for OS key '"-        , T.unpack (T.intercalate "', '" (sort $ Set.toList oskeys))-        , "'.\nSupported versions: "-        , T.unpack (T.intercalate ", " (map compilerVersionText (sort $ Set.toList known)))-        ]-    show (UnknownOSKey oskey) =-        "Unable to find installation URLs for OS key: " ++-        T.unpack oskey-    show (GHCSanityCheckCompileFailed e ghc) = concat-        [ "The GHC located at "-        , toFilePath ghc-        , " failed to compile a sanity check. Please see:\n\n"-        , "    http://docs.haskellstack.org/en/stable/install_and_upgrade/\n\n"-        , "for more information. Exception was:\n"-        , show e-        ]-    show WantedMustBeGHC =-        "The wanted compiler must be GHC"-    show RequireCustomGHCVariant =-        "A custom --ghc-variant must be specified to use --ghc-bindist"-    show (ProblemWhileDecompressing archive) =-        "Problem while decompressing " ++ toFilePath archive-    show SetupInfoMissingSevenz =-        "SetupInfo missing Sevenz EXE/DLL"-    show GHCJSRequiresStandardVariant =-        "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-        [ stackProgName-        , "-"-        , versionString stackVersion'-        , " executable not found for "-        , T.unpack osKey-        , "\nUse the '"-        , T.unpack dockerStackExeArgName-        , "' option to specify a location"]-    show UnsupportedSetupConfiguration =-        "I don't know how to install GHC on your system configuration, please install manually"---- | Modify the environment variables (like PATH) appropriately, possibly doing installation too-setupEnv :: (HasBuildConfig env, HasGHCVariant env)-         => Maybe Text -- ^ Message to give user when necessary GHC is not available-         -> RIO env EnvConfig-setupEnv mResolveMissingGHC = do-    config <- view configL-    bconfig <- view buildConfigL-    let stackYaml = bcStackYaml bconfig-    platform <- view platformL-    wcVersion <- view wantedCompilerVersionL-    wc <- view $ wantedCompilerVersionL.whichCompilerL-    let sopts = SetupOpts-            { soptsInstallIfMissing = configInstallGHC config-            , soptsUseSystem = configSystemGHC config-            , soptsWantedCompiler = wcVersion-            , soptsCompilerCheck = configCompilerCheck config-            , soptsStackYaml = Just stackYaml-            , soptsForceReinstall = False-            , soptsSanityCheck = False-            , soptsSkipGhcCheck = configSkipGHCCheck config-            , soptsSkipMsys = configSkipMsys config-            , soptsUpgradeCabal = Nothing-            , soptsResolveMissingGHC = mResolveMissingGHC-            , soptsSetupInfoYaml = defaultSetupInfoYaml-            , soptsGHCBindistURL = Nothing-            , soptsGHCJSBootOpts = ["--clean"]-            }--    (mghcBin, compilerBuild, _) <- ensureCompiler sopts--    -- Modify the initial environment to include the GHC path, if a local GHC-    -- is being used-    menv0 <- view processContextL-    env <- either throwM (return . removeHaskellEnvVars)-               $ augmentPathMap-                    (map toFilePath $ maybe [] edBins mghcBin)-                    (view envVarsL menv0)-    menv <- mkProcessContext env--    (compilerVer, cabalVer, globaldb) <- withProcessContext menv $ runConcurrently $ (,,)-        <$> Concurrently (getCompilerVersion wc)-        <*> Concurrently (getCabalPkgVer wc)-        <*> Concurrently (getGlobalDB wc)--    logDebug "Resolving package entries"-    packagesRef <- liftIO $ newIORef Nothing-    bc <- view buildConfigL--    -- Set up a modified environment which includes the modified PATH-    -- that GHC can be found on. This is needed for looking up global-    -- package information in loadSnapshot.-    let bcPath :: BuildConfig-        bcPath = set processContextL menv bc--    ls <- runRIO bcPath $ loadSnapshot-      (Just compilerVer)-      (view projectRootL bc)-      (bcSnapshotDef bc)-    let envConfig0 = EnvConfig-            { envConfigBuildConfig = bc-            , envConfigCabalVersion = cabalVer-            , envConfigCompilerVersion = compilerVer-            , envConfigCompilerBuild = compilerBuild-            , envConfigPackagesRef = packagesRef-            , envConfigLoadedSnapshot = ls-            }--    -- extra installation bin directories-    mkDirs <- runReaderT extraBinDirs envConfig0-    let mpath = Map.lookup "PATH" env-    depsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs False) mpath-    localsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs True) mpath--    deps <- runReaderT packageDatabaseDeps envConfig0-    withProcessContext menv $ createDatabase wc deps-    localdb <- runReaderT packageDatabaseLocal envConfig0-    withProcessContext menv $ createDatabase wc localdb-    extras <- runReaderT packageDatabaseExtra envConfig0-    let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb--    distDir <- runReaderT distRelativeDir envConfig0--    executablePath <- liftIO getExecutablePath--    utf8EnvVars <- withProcessContext menv $ getUtf8EnvVars compilerVer--    mGhcRtsEnvVar <- liftIO $ lookupEnv "GHCRTS"--    envRef <- liftIO $ newIORef Map.empty-    let getProcessContext' es = do-            m <- readIORef envRef-            case Map.lookup es m of-                Just eo -> return eo-                Nothing -> do-                    eo <- mkProcessContext-                        $ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath)-                        $ (if esIncludeGhcPackagePath es-                                then Map.insert (ghcPkgPathEnvVar wc) (mkGPP (esIncludeLocals es))-                                else id)--                        $ (if esStackExe es-                                then Map.insert "STACK_EXE" (T.pack executablePath)-                                else id)--                        $ (if esLocaleUtf8 es-                                then Map.union utf8EnvVars-                                else id)--                        $ case (soptsSkipMsys sopts, platform) of-                            (False, Platform Cabal.I386   Cabal.Windows)-                                -> Map.insert "MSYSTEM" "MINGW32"-                            (False, Platform Cabal.X86_64 Cabal.Windows)-                                -> Map.insert "MSYSTEM" "MINGW64"-                            _   -> id--                        -- See https://github.com/commercialhaskell/stack/issues/3444-                        $ case (esKeepGhcRts es, mGhcRtsEnvVar) of-                            (True, Just ghcRts) -> Map.insert "GHCRTS" (T.pack ghcRts)-                            _ -> id--                        -- For reasoning and duplication, see: https://github.com/fpco/stack/issues/70-                        $ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePathNoTrailingSep deps)-                        $ Map.insert "HASKELL_PACKAGE_SANDBOXES"-                            (T.pack $ if esIncludeLocals es-                                then intercalate [searchPathSeparator]-                                        [ toFilePathNoTrailingSep localdb-                                        , toFilePathNoTrailingSep deps-                                        , ""-                                        ]-                                else intercalate [searchPathSeparator]-                                        [ toFilePathNoTrailingSep deps-                                        , ""-                                        ])-                        $ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSep distDir) env--                    () <- atomicModifyIORef envRef $ \m' ->-                        (Map.insert es eo m', ())-                    return eo--    envOverride <- liftIO $ getProcessContext' minimalEnvSettings-    return EnvConfig-        { envConfigBuildConfig = bconfig-            { bcConfig = maybe id addIncludeLib mghcBin-                       $ set processContextL envOverride-                         (view configL bconfig)-                { configProcessContextSettings = getProcessContext'-                }-            }-        , envConfigCabalVersion = cabalVer-        , envConfigCompilerVersion = compilerVer-        , envConfigCompilerBuild = compilerBuild-        , envConfigPackagesRef = envConfigPackagesRef envConfig0-        , envConfigLoadedSnapshot = ls-        }---- | Add the include and lib paths to the given Config-addIncludeLib :: ExtraDirs -> Config -> Config-addIncludeLib (ExtraDirs _bins includes libs) config = config-    { configExtraIncludeDirs = Set.union-        (configExtraIncludeDirs config)-        (Set.fromList (map toFilePathNoTrailingSep includes))-    , configExtraLibDirs = Set.union-        (configExtraLibDirs config)-        (Set.fromList (map toFilePathNoTrailingSep libs))-    }---- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary-ensureCompiler :: (HasConfig env, HasGHCVariant env)-               => SetupOpts-               -> RIO env (Maybe ExtraDirs, CompilerBuild, Bool)-ensureCompiler sopts = do-    let wc = whichCompiler (soptsWantedCompiler sopts)-    when (getGhcVersion (soptsWantedCompiler sopts) < $(mkVersion "7.8")) $ do-        logWarn "Stack will almost certainly fail with GHC below version 7.8"-        logWarn "Valiantly attempting to run anyway, but I know this is doomed"-        logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648"-        logWarn ""--    msystem <--        if soptsUseSystem sopts-            then do-                logDebug "Getting system compiler version"-                getSystemCompiler wc-            else return Nothing--    Platform expectedArch _ <- view platformL--    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 <- view platformL-            localPrograms <- view $ configL.to configLocalPrograms-            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 <- view configL-                                VersionedDownloadInfo version info <--                                    case Map.lookup osKey $ siMsys2 si of-                                        Just x -> return x-                                        Nothing -> throwString $ "MSYS2 not found for " ++ T.unpack osKey-                                let tool = Tool (PackageIdentifier $(mkPackageName "msys2") version)-                                Just <$> downloadAndInstallTool (configLocalPrograms config) si info tool (installMsys2Windows osKey)-                            | otherwise -> do-                                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--            -- Install GHC-            ghcVariant <- view ghcVariantL-            config <- view configL-            let localPrograms = configLocalPrograms config-            installed <- listInstalled localPrograms--            possibleCompilers <--                    case wc of-                        Ghc -> do-                            ghcBuilds <- getGhcBuilds-                            forM ghcBuilds $ \ghcBuild -> do-                                ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)-                                return (getInstalledTool installed ghcPkgName (isWanted . GhcVersion), ghcBuild)-                        Ghcjs -> return [(getInstalledGhcjs installed isWanted, CompilerBuildStandard)]-            let existingCompilers = concatMap-                    (\(installedCompiler, compilerBuild) ->-                        case (installedCompiler, soptsForceReinstall sopts) of-                            (Just tool, False) -> [(tool, compilerBuild)]-                            _ -> [])-                    possibleCompilers-            logDebug $-              "Found already installed GHC builds: " <>-              mconcat (intersperse ", " (map (fromString . compilerBuildName . snd) existingCompilers))-            (compilerTool, compilerBuild) <- case existingCompilers of-                (tool, build_):_ -> return (tool, build_)-                []-                    | soptsInstallIfMissing sopts -> do-                        si <- getSetupInfo'-                        downloadAndInstallPossibleCompilers-                            (map snd possibleCompilers)-                            si-                            (soptsWantedCompiler sopts)-                            (soptsCompilerCheck sopts)-                            (soptsGHCBindistURL sopts)-                    | otherwise -> do-                        recommendSystemGhc <--                            if soptsUseSystem sopts-                                then return False-                                else do-                                    msystemGhc <- getSystemCompiler 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)-                            ghcVariant-                            (case possibleCompilers of-                                [] -> CompilerBuildStandard-                                (_, compilerBuild):_ -> compilerBuild)-                            (soptsCompilerCheck sopts)-                            (soptsStackYaml sopts)-                            suggestion--            -- Install msys2 on windows, if necessary-            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 [compilerTool, mmsys2Tool]-            paths <- mapM extraDirs idents-            return $ Just $ mconcat paths--    menv <--        case mpaths of-            Nothing -> view processContextL-            Just ed -> do-                menv0 <- view processContextL-                m <- either throwM return-                   $ augmentPathMap (toFilePath <$> edBins ed) (view envVarsL menv0)-                mkProcessContext (removeHaskellEnvVars m)--    forM_ (soptsUpgradeCabal sopts) $ \version -> do-        unless needLocal $ do-            logWarn "Trying to change a Cabal library on a GHC not installed by stack."-            logWarn "This may fail, caveat emptor!"-        withProcessContext menv $ upgradeCabal wc version--    case mtools of-        Just (Just (ToolGhcjs cv), _) ->-            withProcessContext menv-          $ ensureGhcjsBooted cv (soptsInstallIfMissing sopts) (soptsGHCJSBootOpts sopts)-        _ -> return ()--    when (soptsSanityCheck sopts) $ withProcessContext menv $ sanityCheck wc--    return (mpaths, compilerBuild, needLocal)---- | Determine which GHC builds to use depending on which shared libraries are available--- on the system.-getGhcBuilds :: HasConfig env => RIO env [CompilerBuild]-getGhcBuilds = do--    config <- view configL-    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 <- view platformL-        case platform of-            Platform _ Cabal.Linux -> do-                -- Some systems don't have ldconfig in the PATH, so make sure to look in /sbin and /usr/sbin as well-                let sbinEnv m = Map.insert-                      "PATH"-                      ("/sbin:/usr/sbin" <> maybe "" (":" <>) (Map.lookup "PATH" m))-                      m-                eldconfigOut-                  <- withModifyEnvVars sbinEnv-                   $ proc "ldconfig" ["-p"]-                   $ tryAny . fmap fst . readProcess_-                let firstWords = case eldconfigOut of-                        Right ldconfigOut -> mapMaybe (listToMaybe . T.words) $-                            T.lines $ T.decodeUtf8With T.lenientDecode-                                    $ LBS.toStrict ldconfigOut-                        Left _ -> []-                    checkLib lib-                        | libT `elem` firstWords = do-                            logDebug ("Found shared library " <> libD <> " 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 " <> libD <> " in /usr/lib")-                                else logDebug ("Did not find shared library " <> libD)-                            return e-#endif-                      where-                        libT = T.pack (toFilePath lib)-                        libD = fromString (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")-                let libComponents = concat-                        [ [["tinfo6"] | hastinfo6 && hasgmp5]-                        , [[] | hastinfo5 && hasgmp5]-                        , [["ncurses6"] | hasncurses6 && hasgmp5 ]-                        , [["gmp4"] | hasgmp4 ]-                        ]-                useBuilds $ map-                    (\c -> case c of-                        [] -> CompilerBuildStandard-                        _ -> CompilerBuildSpecialized (intercalate "-" c))-                    libComponents-#if !WINDOWS-            Platform _ Cabal.OpenBSD -> do-                releaseStr <- mungeRelease <$> sysRelease-                useBuilds [CompilerBuildSpecialized releaseStr]-#endif-            _ -> useBuilds [CompilerBuildStandard]-    useBuilds builds = do-        logDebug $-          "Potential GHC builds: " <>-          mconcat (intersperse ", " (map (fromString . compilerBuildName) builds))-        return builds--#if !WINDOWS--- | Encode an OpenBSD version (like "6.1") into a valid argument for--- CompilerBuildSpecialized, so "maj6-min1". Later version numbers are prefixed--- with "r".--- The result r must be such that "ghc-" ++ r is a valid package name,--- as recognized by parsePackageNameFromString.-mungeRelease :: String -> String-mungeRelease = intercalate "-" . prefixMaj . splitOn "."-  where-    prefixFst pfx k (rev : revs) = (pfx ++ rev) : k revs-    prefixFst _ _ [] = []-    prefixMaj = prefixFst "maj" prefixMin-    prefixMin = prefixFst "min" (map ('r':))--sysRelease :: HasLogFunc env => RIO env String-sysRelease =-  handleIO (\e -> do-               logWarn $ "Could not query OS version" <> displayShow e-               return "") .-  liftIO .-  alloca $ \ ptr ->-             do throwErrnoIfMinus1_ "uname" $ uname ptr-                peekCString $ release ptr-#endif---- | Ensure Docker container-compatible 'stack' executable is downloaded-ensureDockerStackExe :: HasConfig env => Platform -> RIO env (Path Abs File)-ensureDockerStackExe containerPlatform = do-    config <- view configL-    containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone)-    let programsPath = configLocalProgramsBase config </> containerPlatformDir-        tool = Tool (PackageIdentifier $(mkPackageName "stack") stackVersion)-    stackExeDir <- installDir programsPath tool-    let stackExePath = stackExeDir </> $(mkRelFile "stack")-    stackExeExists <- doesFileExist stackExePath-    unless stackExeExists $ do-        logInfo $-          "Downloading Docker-compatible " <>-          fromString stackProgName <>-          " executable"-        sri <- downloadStackReleaseInfo Nothing Nothing (Just (versionString stackMinorVersion))-        platforms <- runReaderT preferredPlatforms (containerPlatform, PlatformVariantNone)-        downloadStackExe platforms sri stackExeDir False (const $ return ())-    return stackExePath---- | Install the newest version or a specific version of Cabal globally-upgradeCabal :: (HasConfig env, HasGHCVariant env)-             => WhichCompiler-             -> UpgradeTo-             -> RIO env ()-upgradeCabal wc upgradeTo = do-    logWarn "Using deprecated --upgrade-cabal feature, this is not recommended"-    logWarn "Manipulating the global Cabal is only for debugging purposes"-    let name = $(mkPackageName "Cabal")-    rmap <- resolvePackages Nothing mempty (Set.singleton name)-    installed <- getCabalPkgVer wc-    case upgradeTo of-        Specific wantedVersion -> do-            if installed /= wantedVersion then-                doCabalInstall wc installed wantedVersion-            else-                logInfo $-                  "No install necessary. Cabal " <>-                  RIO.display installed <>-                  " is already installed"-        Latest     -> case map rpIdent rmap of-            [] -> throwString "No Cabal library found in index, cannot upgrade"-            [PackageIdentifier name' latestVersion] | name == name' -> do-                if installed < latestVersion then-                    doCabalInstall wc installed latestVersion-                else-                    logInfo $-                        "No upgrade necessary: Cabal-" <>-                        RIO.display latestVersion <>-                        " is the same or newer than latest hackage version " <>-                        RIO.display installed-            x -> error $ "Unexpected results for resolvePackages: " ++ show x---- Configure and run the necessary commands for a cabal install-doCabalInstall :: (HasConfig env, HasGHCVariant env)-               => WhichCompiler-               -> Version-               -> Version-               -> RIO env ()-doCabalInstall wc installed wantedVersion = do-    when (wantedVersion >= $(mkVersion "2.2")) $ do-        logWarn "--upgrade-cabal will almost certainly fail for Cabal 2.2 or later"-        logWarn "See: https://github.com/commercialhaskell/stack/issues/4070"-        logWarn "Valiantly attempting to build it anyway, but I know this is doomed"-    withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> do-        logInfo $-            "Installing Cabal-" <>-            RIO.display wantedVersion <>-            " to replace " <>-            RIO.display installed-        let name = $(mkPackageName "Cabal")-            ident = PackageIdentifier name wantedVersion-        m <- unpackPackageIdents tmpdir Nothing [PackageIdentifierRevision ident CFILatest]-        compilerPath <- findExecutable (compilerExeName wc)-                    >>= either throwM parseAbsFile-        versionDir <- parseRelDir $ versionString wantedVersion-        let installRoot = toFilePath $ parent (parent compilerPath)-                                    </> $(mkRelDir "new-cabal")-                                    </> versionDir-        dir <- case Map.lookup ident m of-            Nothing -> error "upgradeCabal: Invariant violated, dir missing"-            Just dir -> return dir-        withWorkingDir (toFilePath dir) $ proc (compilerExeName wc) ["Setup.hs"] runProcess_-        platform <- view platformL-        let setupExe = toFilePath $ dir </> case platform of-                Platform _ Cabal.Windows -> $(mkRelFile "Setup.exe")-                _                        -> $(mkRelFile "Setup")-            dirArgument name' = concat [ "--"-                                       , name'-                                       , "dir="-                                       , installRoot FP.</> name'-                                       ]-            args = "configure" : map dirArgument (words "lib bin data doc")-        withWorkingDir (toFilePath dir) $ do-          proc setupExe args runProcess_-          proc setupExe ["build"] runProcess_-          proc setupExe ["install"] runProcess_-        logInfo "New Cabal library installed"---- | Get the version of the system compiler, if available-getSystemCompiler-  :: (HasProcessContext env, HasLogFunc env)-  => WhichCompiler-  -> RIO env (Maybe (CompilerVersion 'CVActual, Arch))-getSystemCompiler wc = do-    let exeName = case wc of-            Ghc -> "ghc"-            Ghcjs -> "ghcjs"-    exists <- doesExecutableExist exeName-    if exists-        then do-            eres <- proc exeName ["--info"] $ tryAny . fmap fst . readProcess_-            let minfo = do-                    Right lbs <- Just eres-                    pairs_ <- readMaybe $ BL8.unpack lbs :: Maybe [(String, String)]-                    version <- lookup "Project version" pairs_ >>= parseVersionFromString-                    arch <- lookup "Target platform" pairs_ >>= simpleParse . takeWhile (/= '-')-                    return (version, arch)-            case (wc, minfo) of-                (Ghc, Just (version, arch)) -> return (Just (GhcVersion version, arch))-                (Ghcjs, Just (_, arch)) -> do-                    eversion <- tryAny $ getCompilerVersion Ghcjs-                    case eversion of-                        Left _ -> return Nothing-                        Right version -> return (Just (version, arch))-                (_, Nothing) -> return Nothing-        else return Nothing---- | Download the most recent SetupInfo-getSetupInfo :: HasConfig env => String -> RIO env SetupInfo-getSetupInfo stackSetupYaml = do-    config <- view configL-    setupInfos <--        mapM-            loadSetupInfo-            (SetupInfoFileOrURL stackSetupYaml :-             configSetupInfoLocations config)-    return (mconcat setupInfos)-  where-    loadSetupInfo (SetupInfoInline si) = return si-    loadSetupInfo (SetupInfoFileOrURL urlOrFile) = do-        bs <--            case parseUrlThrow urlOrFile of-                Just req -> liftM (LBS.toStrict . getResponseBody) $ httpLBS req-                Nothing -> liftIO $ S.readFile urlOrFile-        WithJSONWarnings si warnings <- either throwM return (Yaml.decodeEither' bs)-        when (urlOrFile /= defaultSetupInfoYaml) $-            logJSONWarnings urlOrFile warnings-        return si--getInstalledTool :: [Tool]            -- ^ already installed-                 -> PackageName       -- ^ package to find-                 -> (Version -> Bool) -- ^ which versions are acceptable-                 -> Maybe Tool-getInstalledTool installed name goodVersion =-    if null available-        then Nothing-        else Just $ Tool $ maximumBy (comparing packageIdentifierVersion) available-  where-    available = mapMaybe goodPackage installed-    goodPackage (Tool pi') =-        if packageIdentifierName pi' == name &&-           goodVersion (packageIdentifierVersion pi')-            then Just pi'-            else Nothing-    goodPackage _ = Nothing--getInstalledGhcjs :: [Tool]-                  -> (CompilerVersion 'CVActual -> Bool)-                  -> Maybe Tool-getInstalledGhcjs installed goodVersion =-    if null available-        then Nothing-        else Just $ ToolGhcjs $ maximum available-  where-    available = mapMaybe goodPackage installed-    goodPackage (ToolGhcjs cv) = if goodVersion cv then Just cv else Nothing-    goodPackage _ = Nothing--downloadAndInstallTool :: HasRunner env-                       => Path Abs Dir-                       -> SetupInfo-                       -> DownloadInfo-                       -> Tool-                       -> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ())-                       -> RIO env Tool-downloadAndInstallTool programsDir si downloadInfo tool installer = do-    ensureDir programsDir-    (file, at) <- downloadFromInfo programsDir downloadInfo tool-    dir <- installDir programsDir tool-    tempDir <- tempInstallDir programsDir tool-    liftIO $ ignoringAbsence (removeDirRecur tempDir)-    ensureDir tempDir-    unmarkInstalled programsDir tool-    installer si file at tempDir dir-    markInstalled programsDir tool-    liftIO $ ignoringAbsence (removeDirRecur tempDir)-    return tool--downloadAndInstallCompiler :: (HasConfig env, HasGHCVariant env)-                           => CompilerBuild-                           -> SetupInfo-                           -> CompilerVersion 'CVWanted-                           -> VersionCheck-                           -> Maybe String-                           -> RIO env Tool-downloadAndInstallCompiler ghcBuild si wanted@GhcVersion{} versionCheck mbindistURL = do-    ghcVariant <- view ghcVariantL-    (selectedVersion, downloadInfo) <- case mbindistURL of-        Just bindistURL -> do-            case ghcVariant of-                GHCCustom _ -> return ()-                _ -> throwM RequireCustomGHCVariant-            case wanted of-                GhcVersion version ->-                    return (version, GHCDownloadInfo mempty mempty DownloadInfo-                             { downloadInfoUrl = T.pack bindistURL-                             , downloadInfoContentLength = Nothing-                             , downloadInfoSha1 = Nothing-                             , downloadInfoSha256 = Nothing-                             })-                _ ->-                    throwM WantedMustBeGHC-        _ -> do-            ghcKey <- getGhcKey ghcBuild-            case Map.lookup ghcKey $ siGHCs si of-                Nothing -> throwM $ UnknownOSKey ghcKey-                Just pairs_ -> getWantedCompilerInfo ghcKey versionCheck wanted GhcVersion pairs_-    config <- view configL-    let installer =-            case configPlatform config of-                Platform _ Cabal.Windows -> installGHCWindows selectedVersion-                _ -> installGHCPosix selectedVersion downloadInfo-    logInfo $-        "Preparing to install GHC" <>-        (case ghcVariant of-            GHCStandard -> ""-            v -> " (" <> fromString (ghcVariantName v) <> ")") <>-        (case ghcBuild of-            CompilerBuildStandard -> ""-            b -> " (" <> fromString (compilerBuildName b) <> ")") <>-        " to an isolated location."-    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 (gdiDownloadInfo downloadInfo) tool installer-downloadAndInstallCompiler compilerBuild si wanted versionCheck _mbindistUrl = do-    config <- view configL-    ghcVariant <- view ghcVariantL-    case (ghcVariant, compilerBuild) of-        (GHCStandard, CompilerBuildStandard) -> return ()-        _ -> throwM GHCJSRequiresStandardVariant-    (selectedVersion, downloadInfo) <- case Map.lookup "source" $ siGHCJSs si of-        Nothing -> throwM $ UnknownOSKey "source"-        Just pairs_ -> getWantedCompilerInfo "source" versionCheck wanted id pairs_-    logInfo "Preparing to install GHCJS to an isolated location."-    logInfo "This will not interfere with any system-level installation."-    let tool = ToolGhcjs selectedVersion-    downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installGHCJS--getWantedCompilerInfo :: (Ord k, MonadThrow m)-                      => Text-                      -> VersionCheck-                      -> CompilerVersion 'CVWanted-                      -> (k -> CompilerVersion 'CVActual)-                      -> Map k a-                      -> m (k, a)-getWantedCompilerInfo key versionCheck wanted toCV pairs_ =-    case mpair of-        Just pair -> return pair-        Nothing -> throwM $ UnknownCompilerVersion (Set.singleton key) wanted (Set.fromList $ map toCV (Map.keys pairs_))-  where-    mpair =-        listToMaybe $-        sortBy (flip (comparing fst)) $-        filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs_)---- | Download and install the first available compiler build.-downloadAndInstallPossibleCompilers-    :: (HasGHCVariant env, HasConfig env)-    => [CompilerBuild]-    -> SetupInfo-    -> CompilerVersion 'CVWanted-    -> VersionCheck-    -> Maybe String-    -> RIO env (Tool, CompilerBuild)-downloadAndInstallPossibleCompilers possibleCompilers si wanted versionCheck mbindistURL =-    go possibleCompilers Nothing-  where-    -- This will stop as soon as one of the builds doesn't throw an @UnknownOSKey@ or-    -- @UnknownCompilerVersion@ exception (so it will only try subsequent builds if one is non-existent,-    -- not if the download or install fails for some other reason).-    -- The @Unknown*@ exceptions thrown by each attempt are combined into a single exception-    -- (if only @UnknownOSKey@ is thrown, then the first of those is rethrown, but if any-    -- @UnknownCompilerVersion@s are thrown then the attempted OS keys and available versions-    -- are unioned).-    go [] Nothing = throwM UnsupportedSetupConfiguration-    go [] (Just e) = throwM e-    go (b:bs) e = do-        logDebug $ "Trying to setup GHC build: " <> fromString (compilerBuildName b)-        er <- try $ downloadAndInstallCompiler b si wanted versionCheck mbindistURL-        case er of-            Left e'@(UnknownCompilerVersion ks' w' vs') ->-                case e of-                    Nothing -> go bs (Just e')-                    Just (UnknownOSKey k) ->-                        go bs $ Just $ UnknownCompilerVersion (Set.insert k ks') w' vs'-                    Just (UnknownCompilerVersion ks _ vs) ->-                        go bs $ Just $ UnknownCompilerVersion (Set.union ks' ks) w' (Set.union vs' vs)-                    Just x -> throwM x-            Left e'@(UnknownOSKey k') ->-                case e of-                    Nothing -> go bs (Just e')-                    Just (UnknownOSKey _) -> go bs e-                    Just (UnknownCompilerVersion ks w vs) ->-                        go bs $ Just $ UnknownCompilerVersion (Set.insert k' ks) w vs-                    Just x -> throwM x-            Left e' -> throwM e'-            Right r -> return (r, b)--getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)-          => CompilerBuild -> m Text-getGhcKey ghcBuild = do-    ghcVariant <- view ghcVariantL-    platform <- view platformL-    osKey <- getOSKey platform-    return $ osKey <> T.pack (ghcVariantSuffix ghcVariant) <> T.pack (compilerBuildSuffix ghcBuild)--getOSKey :: (MonadThrow m)-         => Platform -> m Text-getOSKey platform =-    case platform of-        Platform I386                  Cabal.Linux   -> return "linux32"-        Platform X86_64                Cabal.Linux   -> return "linux64"-        Platform I386                  Cabal.OSX     -> return "macosx"-        Platform X86_64                Cabal.OSX     -> return "macosx"-        Platform I386                  Cabal.FreeBSD -> return "freebsd32"-        Platform X86_64                Cabal.FreeBSD -> return "freebsd64"-        Platform I386                  Cabal.OpenBSD -> return "openbsd32"-        Platform X86_64                Cabal.OpenBSD -> return "openbsd64"-        Platform I386                  Cabal.Windows -> return "windows32"-        Platform X86_64                Cabal.Windows -> return "windows64"-        Platform Arm                   Cabal.Linux   -> return "linux-armv7"-        Platform (OtherArch "aarch64") Cabal.Linux   -> return "linux-aarch64"-        Platform arch os -> throwM $ UnsupportedSetupCombo os arch--downloadFromInfo-    :: HasRunner env-    => Path Abs Dir -> DownloadInfo -> Tool -> RIO env (Path Abs File, ArchiveType)-downloadFromInfo programsDir downloadInfo tool = do-    at <--        case extension of-            ".tar.xz" -> return TarXz-            ".tar.bz2" -> return TarBz2-            ".tar.gz" -> return TarGz-            ".7z.exe" -> return SevenZ-            _ -> throwString $ "Error: Unknown extension for url: " ++ url-    relativeFile <- parseRelFile $ toolString tool ++ extension-    path <- case url of-        (parseUrlThrow -> Just _) -> do-            let path = programsDir </> relativeFile-            ensureDir programsDir-            chattyDownload (T.pack (toolString tool)) downloadInfo path-            return path-        (parseAbsFile -> Just path) -> do-            let DownloadInfo{downloadInfoContentLength=contentLength, downloadInfoSha1=sha1,-                             downloadInfoSha256=sha256} =-                    downloadInfo-            when (isJust contentLength) $-                logWarn ("`content-length` in not checked \n" <>-                          "and should not be specified when `url` is a file path")-            when (isJust sha1) $-                logWarn ("`sha1` is not checked and \n" <>-                          "should not be specified when `url` is a file path")-            when (isJust sha256) $-                logWarn ("`sha256` is not checked and \n" <>-                          "should not be specified when `url` is a file path")-            return path-        _ ->-            throwString $ "Error: `url` must be either an HTTP URL or absolute file path: " ++ url-    return (path, at)-  where-    url = T.unpack $ downloadInfoUrl downloadInfo-    extension = loop url-      where-        loop fp-            | ext `elem` [".tar", ".bz2", ".xz", ".exe", ".7z", ".gz"] = loop fp' ++ ext-            | otherwise = ""-          where-            (fp', ext) = FP.splitExtension fp--data ArchiveType-    = TarBz2-    | TarXz-    | TarGz-    | SevenZ--installGHCPosix :: HasConfig env-                => Version-                -> GHCDownloadInfo-                -> SetupInfo-                -> Path Abs File-                -> ArchiveType-                -> Path Abs Dir-                -> Path Abs Dir-                -> RIO env ()-installGHCPosix version downloadInfo _ archiveFile archiveType tempDir destDir = do-    platform <- view platformL-    menv0 <- view processContextL-    menv <- mkProcessContext (removeHaskellEnvVars (view envVarsL menv0))-    logDebug $ "menv = " <> displayShow (view envVarsL menv)-    (zipTool', compOpt) <--        case archiveType of-            TarXz -> return ("xz", 'J')-            TarBz2 -> return ("bzip2", 'j')-            TarGz -> return ("gzip", 'z')-            SevenZ -> throwString "Don't know how to deal with .7z files on non-Windows"-    -- Slight hack: OpenBSD's tar doesn't support xz.-    -- https://github.com/commercialhaskell/stack/issues/2283#issuecomment-237980986-    let tarDep =-          case (platform, archiveType) of-            (Platform _ Cabal.OpenBSD, TarXz) -> checkDependency "gtar"-            _ -> checkDependency "tar"-    (zipTool, makeTool, tarTool) <- checkDependencies $ (,,)-        <$> checkDependency zipTool'-        <*> (checkDependency "gmake" <|> checkDependency "make")-        <*> tarDep--    logDebug $ "ziptool: " <> fromString zipTool-    logDebug $ "make: " <> fromString makeTool-    logDebug $ "tar: " <> fromString tarTool--    dir <--        liftM (tempDir </>) $-        parseRelDir $-        "ghc-" ++ versionString version--    let runStep step wd env cmd args = do-            menv' <- modifyEnvVars menv (Map.union env)-            result <- do-                let logLines = CB.lines .| CL.mapM_ (logDebug . displayBytesUtf8)-                withWorkingDir (toFilePath wd)-                  $ withProcessContext menv'-                  $ try-                  $ sinkProcessStderrStdout cmd args logLines logLines--            case result of-                Right ((), ()) -> return ()-                Left ex -> do-                    logError (displayShow (ex :: ProcessException))-                    prettyError $-                        hang 2-                          ("Error encountered while" <+> step <+> "GHC with" <> line <>-                           styleShell (fromString (unwords (cmd : args))) <> line <>-                           -- TODO: Figure out how to insert \ in the appropriate spots-                           -- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>-                           "run in " <> display wd) <> line <> line <>-                        "The following directories may now contain files, but won't be used by stack:" <> line <>-                        "  -" <+> display tempDir <> line <>-                        "  -" <+> display destDir <> line-                    liftIO System.Exit.exitFailure--    logSticky $-      "Unpacking GHC into " <>-      fromString (toFilePath tempDir) <>-      " ..."-    logDebug $ "Unpacking " <> fromString (toFilePath archiveFile)-    runStep "unpacking" tempDir mempty tarTool [compOpt : "xf", toFilePath archiveFile]--    logSticky "Configuring GHC ..."-    runStep "configuring" dir-        (gdiConfigureEnv downloadInfo)-        (toFilePath $ dir </> $(mkRelFile "configure"))-        (("--prefix=" ++ toFilePath destDir) : map T.unpack (gdiConfigureOpts downloadInfo))--    logSticky "Installing GHC ..."-    runStep "installing" dir mempty makeTool ["install"]--    logStickyDone $ "Installed GHC."-    logDebug $ "GHC installed to " <> fromString (toFilePath destDir)--installGHCJS :: HasConfig env-             => SetupInfo-             -> Path Abs File-             -> ArchiveType-             -> Path Abs Dir-             -> Path Abs Dir-             -> RIO env ()-installGHCJS si archiveFile archiveType _tempDir destDir = do-    platform <- view platformL-    menv0 <- view processContextL-    -- This ensures that locking is disabled for the invocations of-    -- stack below.-    let removeLockVar = Map.delete "STACK_LOCK"-    menv <- mkProcessContext (removeLockVar (removeHaskellEnvVars (view envVarsL menv0)))-    logDebug $ "menv = " <> displayShow (view envVarsL menv)--    -- NOTE: this is a bit of a hack - instead of using the temp-    -- directory, leave the unpacked source tarball in the destination-    -- directory. This way, the absolute paths in the wrapper scripts-    -- will point to executables that exist in-    -- src/.stack-work/install/... - see-    -- https://github.com/commercialhaskell/stack/issues/1016-    ---    -- This is also used by 'ensureGhcjsBooted', because it can use the-    -- environment of the stack.yaml which came with ghcjs, in order to-    -- install cabal-install. This lets us also fix the version of-    -- cabal-install used.-    let unpackDir = destDir </> $(mkRelDir "src")-    runUnpack <- case platform of-        Platform _ Cabal.Windows -> return $-            withUnpackedTarball7z "GHCJS" si archiveFile archiveType Nothing unpackDir-        _ -> do-            zipTool' <--                case archiveType of-                    TarXz -> return "xz"-                    TarBz2 -> return "bzip2"-                    TarGz -> return "gzip"-                    SevenZ -> throwString "Don't know how to deal with .7z files on non-Windows"-            (zipTool, tarTool) <- checkDependencies $ (,)-                <$> checkDependency zipTool'-                <*> checkDependency "tar"-            logDebug $ "ziptool: " <> fromString zipTool-            logDebug $ "tar: " <> fromString tarTool-            return $ do-                liftIO $ ignoringAbsence (removeDirRecur destDir)-                liftIO $ ignoringAbsence (removeDirRecur unpackDir)-                withProcessContext menv $ withWorkingDir (toFilePath destDir) $ readProcessNull tarTool ["xf", toFilePath archiveFile]-                innerDir <- expectSingleUnpackedDir archiveFile destDir-                renameDir innerDir unpackDir--    logSticky $-      "Unpacking GHCJS into " <>-      fromString (toFilePath unpackDir) <>-      " ..."-    logDebug $ "Unpacking " <> fromString (toFilePath archiveFile)-    runUnpack--    logSticky "Setting up GHCJS build environment"-    let stackYaml = unpackDir </> $(mkRelFile "stack.yaml")-        destBinDir = destDir </> $(mkRelDir "bin")-    ensureDir destBinDir-    envConfig' <- loadGhcjsEnvConfig stackYaml destBinDir--    -- On windows we need to copy options files out of the install dir.  Argh!-    -- This is done before the build, so that if it fails, things fail-    -- earlier.-    mwindowsInstallDir <- case platform of-        Platform _ Cabal.Windows ->-            liftM Just $ runRIO envConfig' installationRootLocal-        _ -> return Nothing--    logSticky "Installing GHCJS (this will take a long time) ..."-    buildInGhcjsEnv envConfig' defaultBuildOptsCLI-    -- Copy over *.options files needed on windows.-    forM_ mwindowsInstallDir $ \dir -> do-        (_, files) <- listDir (dir </> $(mkRelDir "bin"))-        forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do-            let dest = destDir </> $(mkRelDir "bin") </> filename optionsFile-            liftIO $ ignoringAbsence (removeFile dest)-            copyFile optionsFile dest-    logStickyDone "Installed GHCJS."--ensureGhcjsBooted :: HasConfig env-                  => CompilerVersion 'CVActual -> Bool -> [String]-                  -> RIO env ()-ensureGhcjsBooted cv shouldBoot bootOpts = do-    eres <- try $ sinkProcessStdout "ghcjs" [] (return ())-    case eres of-        Right () -> return ()-        Left ece | "no input files" `S.isInfixOf` LBS.toStrict (eceStderr ece) ->-            return ()-        Left ece | "ghcjs_boot.completed" `S.isInfixOf` LBS.toStrict (eceStderr ece) ->-            if not shouldBoot then throwM GHCJSNotBooted else do-                config <- view configL-                destDir <- installDir (configLocalPrograms config) (ToolGhcjs cv)-                let stackYaml = destDir </> $(mkRelFile "src/stack.yaml")-                -- TODO: Remove 'actualStackYaml' and just use-                -- 'stackYaml' for a version after 0.1.6. It's for-                -- compatibility with the directories setup used for-                -- most of the life of the development branch between-                -- 0.1.5 and 0.1.6. See-                -- https://github.com/commercialhaskell/stack/issues/749#issuecomment-147382783-                -- This only affects the case where GHCJS has been-                -- installed with an older version and not yet booted.-                stackYamlExists <- doesFileExist stackYaml-                ghcjsVersion <- case cv of-                        GhcjsVersion version _ -> return version-                        _ -> error "ensureGhcjsBooted invoked on non GhcjsVersion"-                actualStackYaml <- if stackYamlExists then return stackYaml-                    else-                        liftM ((destDir </> $(mkRelDir "src")) </>) $-                        parseRelFile $ "ghcjs-" ++ versionString ghcjsVersion ++ "/stack.yaml"-                actualStackYamlExists <- doesFileExist actualStackYaml-                unless actualStackYamlExists $-                    throwString "Error: Couldn't find GHCJS stack.yaml in old or new location."-                bootGhcjs ghcjsVersion actualStackYaml destDir bootOpts-        Left ece -> throwIO ece--bootGhcjs :: (HasRunner env, HasProcessContext env)-          => Version -> Path Abs File -> Path Abs Dir -> [String] -> RIO env ()-bootGhcjs ghcjsVersion stackYaml destDir bootOpts = do-    envConfig <- loadGhcjsEnvConfig stackYaml (destDir </> $(mkRelDir "bin"))-    menv <- liftIO $ configProcessContextSettings (view configL envConfig) defaultEnvSettings-    -- Install cabal-install if missing, or if the installed one is old.-    mcabal <- withProcessContext menv getCabalInstallVersion-    shouldInstallCabal <- case mcabal of-        Nothing -> do-            logInfo "No cabal-install binary found for use with GHCJS."-            return True-        Just v-            | v < $(mkVersion "1.22.4") -> do-                logInfo $-                    "The cabal-install found on PATH is too old to be used for booting GHCJS (version " <>-                    RIO.display v <>-                    ")."-                return True-            | v >= $(mkVersion "1.23") -> do-                logWarn $-                    "The cabal-install found on PATH is a version stack doesn't know about, version " <>-                    RIO.display v <>-                    ". This may or may not work.\n" <>-                    "See this issue: https://github.com/ghcjs/ghcjs/issues/470"-                return False-            | ghcjsVersion >= $(mkVersion "0.2.0.20160413") && v >= $(mkVersion "1.22.8") -> do-                logWarn $-                    "The cabal-install found on PATH, version " <>-                    RIO.display v <>-                    ", is >= 1.22.8.\n" <>-                    "That version has a bug preventing ghcjs < 0.2.0.20160413 from booting.\n" <>-                    "See this issue: https://github.com/ghcjs/ghcjs/issues/470"-                return True-            | otherwise -> return False-    let envSettings = EnvSettings-          { esIncludeLocals = True-          , esIncludeGhcPackagePath = False-          , esStackExe = True-          , esLocaleUtf8 = True-          , esKeepGhcRts = False-          }-    menv' <- liftIO $ configProcessContextSettings (view configL envConfig) envSettings-    shouldInstallAlex <- runRIO menv $ not <$> doesExecutableExist "alex"-    shouldInstallHappy <- runRIO menv $ not <$> doesExecutableExist "happy"-    let bootDepsToInstall =-          [ "cabal-install" | shouldInstallCabal ] ++-          [ "alex" | shouldInstallAlex ] ++-          [ "happy" | shouldInstallHappy ]-    when (not (null bootDepsToInstall)) $ do-        logInfo $ "Building tools from source, needed for ghcjs-boot: " <> displayShow bootDepsToInstall-        buildInGhcjsEnv envConfig $ defaultBuildOptsCLI { boptsCLITargets = bootDepsToInstall }-        let failedToFindErr = do-                logError "This shouldn't happen, because it gets built to the snapshot bin directory, which should be treated as being on the PATH."-                liftIO System.Exit.exitFailure-        when shouldInstallCabal $ do-            mcabal' <- withProcessContext menv' getCabalInstallVersion-            case mcabal' of-                Nothing -> do-                    logError "Failed to get cabal-install version after installing it."-                    failedToFindErr-                Just v | v >= $(mkVersion "1.22.8") && v < $(mkVersion "1.23") ->-                    logWarn $-                        "Installed version of cabal-install is in a version range which may not work.\n" <>-                        "See this issue: https://github.com/ghcjs/ghcjs/issues/470\n" <>-                        "This version is specified by the stack.yaml file included in the ghcjs tarball.\n"-                _ -> return ()-        when shouldInstallAlex $ do-            alexInstalled <- runRIO menv $ doesExecutableExist "alex"-            when (not alexInstalled) $ do-                logError "Failed to find 'alex' executable after installing it."-                failedToFindErr-        when shouldInstallHappy $ do-            happyInstalled <- runRIO menv $ doesExecutableExist "happy"-            when (not happyInstalled) $ do-                logError "Failed to find 'happy' executable after installing it."-                failedToFindErr-    logSticky "Booting GHCJS (this will take a long time) ..."-    withProcessContext menv' $ proc "ghcjs-boot" bootOpts logProcessStderrStdout-    logStickyDone "GHCJS booted."--loadGhcjsEnvConfig :: HasRunner env-                   => Path Abs File -> Path b t -> RIO env EnvConfig-loadGhcjsEnvConfig stackYaml binPath = do-    lc <- loadConfig-        (mempty-            { configMonoidInstallGHC = First (Just True)-            , configMonoidLocalBinPath = First (Just (toFilePath binPath))-            })-        Nothing-        (SYLOverride stackYaml)-    bconfig <- liftIO $ lcLoadBuildConfig lc Nothing-    runRIO bconfig $ setupEnv Nothing--buildInGhcjsEnv :: (HasEnvConfig env, MonadIO m) => env -> BuildOptsCLI -> m ()-buildInGhcjsEnv envConfig boptsCli = do-    runRIO (set (buildOptsL.buildOptsInstallExesL) True $-            set (buildOptsL.buildOptsHaddockL) False envConfig) $-        build (\_ -> return ()) Nothing boptsCli--getCabalInstallVersion :: (HasProcessContext env, HasLogFunc env) => RIO env (Maybe Version)-getCabalInstallVersion = do-    ebs <- tryAny $ proc "cabal" ["--numeric-version"] readProcess_-    case ebs of-        Left _ -> return Nothing-        Right (bs, _) -> Just <$> parseVersion (T.dropWhileEnd isSpace (T.decodeUtf8 (LBS.toStrict bs)))---- | Check if given processes appear to be present, throwing an exception if--- missing.-checkDependencies :: CheckDependency env a -> RIO env a-checkDependencies (CheckDependency f) = f >>= either (throwIO . MissingDependencies) return--checkDependency :: HasProcessContext env => String -> CheckDependency env String-checkDependency tool = CheckDependency $ do-    exists <- doesExecutableExist tool-    return $ if exists then Right tool else Left [tool]--newtype CheckDependency env a = CheckDependency (RIO env (Either [String] a))-    deriving Functor-instance Applicative (CheckDependency env) where-    pure x = CheckDependency $ return (Right x)-    CheckDependency f <*> CheckDependency x = CheckDependency $ do-        f' <- f-        x' <- x-        return $-            case (f', x') of-                (Left e1, Left e2) -> Left $ e1 ++ e2-                (Left e, Right _) -> Left e-                (Right _, Left e) -> Left e-                (Right f'', Right x'') -> Right $ f'' x''-instance Alternative (CheckDependency env) where-    empty = CheckDependency $ return $ Left []-    CheckDependency x <|> CheckDependency y = CheckDependency $ do-        res1 <- x-        case res1 of-            Left _ -> y-            Right x' -> return $ Right x'--installGHCWindows :: HasConfig env-                  => Version-                  -> SetupInfo-                  -> Path Abs File-                  -> ArchiveType-                  -> Path Abs Dir-                  -> Path Abs Dir-                  -> RIO env ()-installGHCWindows version si archiveFile archiveType _tempDir destDir = do-    tarComponent <- parseRelDir $ "ghc-" ++ versionString version-    withUnpackedTarball7z "GHC" si archiveFile archiveType (Just tarComponent) destDir-    logInfo $ "GHC installed to " <> fromString (toFilePath destDir)--installMsys2Windows :: HasConfig env-                  => Text -- ^ OS Key-                  -> SetupInfo-                  -> Path Abs File-                  -> ArchiveType-                  -> Path Abs Dir-                  -> Path Abs Dir-                  -> RIO env ()-installMsys2Windows osKey si archiveFile archiveType _tempDir destDir = do-    exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir-    when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do-        logError $-            "Could not delete existing msys directory: " <>-            fromString (toFilePath destDir)-        throwM e--    msys <- parseRelDir $ "msys" ++ T.unpack (fromMaybe "32" $ T.stripPrefix "windows" osKey)-    withUnpackedTarball7z "MSYS2" si archiveFile archiveType (Just msys) destDir---    -- I couldn't find this officially documented anywhere, but you need to run-    -- the MSYS shell once in order to initialize some pacman stuff. Once that-    -- run happens, you can just run commands as usual.-    menv0 <- view processContextL-    newEnv0 <- modifyEnvVars menv0 $ Map.insert "MSYSTEM" "MSYS"-    newEnv <- either throwM return $ augmentPathMap-                  [toFilePath $ destDir </> $(mkRelDir "usr") </> $(mkRelDir "bin")]-                  (view envVarsL newEnv0)-    menv <- mkProcessContext newEnv-    withWorkingDir (toFilePath destDir) $ withProcessContext menv-      $ proc "sh" ["--login", "-c", "true"] runProcess_--    -- No longer installing git, it's unreliable-    -- (https://github.com/commercialhaskell/stack/issues/1046) and the-    -- MSYS2-installed version has bad CRLF defaults.-    ---    -- Install git. We could install other useful things in the future too.-    -- runCmd (Cmd (Just destDir) "pacman" menv ["-Sy", "--noconfirm", "git"]) Nothing---- | Unpack a compressed tarball using 7zip.  Expects a single directory in--- the unpacked results, which is renamed to the destination directory.-withUnpackedTarball7z :: HasConfig env-                      => String -- ^ Name of tool, used in error messages-                      -> SetupInfo-                      -> Path Abs File -- ^ Path to archive file-                      -> ArchiveType-                      -> Maybe (Path Rel Dir) -- ^ Name of directory expected in archive.  If Nothing, expects a single folder.-                      -> Path Abs Dir -- ^ Destination directory.-                      -> RIO env ()-withUnpackedTarball7z name si archiveFile archiveType msrcDir destDir = do-    suffix <--        case archiveType of-            TarXz -> return ".xz"-            TarBz2 -> return ".bz2"-            TarGz -> return ".gz"-            _ -> throwString $ name ++ " must be a tarball file"-    tarFile <--        case T.stripSuffix suffix $ T.pack $ toFilePath (filename archiveFile) of-            Nothing -> throwString $ "Invalid " ++ name ++ " filename: " ++ show archiveFile-            Just x -> parseRelFile $ T.unpack x-    run7z <- setup7z si-    let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp"-    ensureDir (parent destDir)-    withRunInIO $ \run -> withTempDir (parent destDir) tmpName $ \tmpDir -> run $ do-        liftIO $ ignoringAbsence (removeDirRecur destDir)-        run7z tmpDir archiveFile-        run7z tmpDir (tmpDir </> tarFile)-        absSrcDir <- case msrcDir of-            Just srcDir -> return $ tmpDir </> srcDir-            Nothing -> expectSingleUnpackedDir archiveFile tmpDir-        renameDir absSrcDir destDir--expectSingleUnpackedDir :: (MonadIO m, MonadThrow m) => Path Abs File -> Path Abs Dir -> m (Path Abs Dir)-expectSingleUnpackedDir archiveFile destDir = do-    contents <- listDir destDir-    case contents of-        ([dir], _ ) -> return dir-        _ -> throwString $ "Expected a single directory within unpacked " ++ toFilePath archiveFile---- | Download 7z as necessary, and get a function for unpacking things.------ Returned function takes an unpack directory and archive.-setup7z :: (HasConfig env, MonadIO m)-        => SetupInfo-        -> RIO env (Path Abs Dir -> Path Abs File -> m ())-setup7z si = do-    dir <- view $ configL.to configLocalPrograms-    ensureDir dir-    let exe = dir </> $(mkRelFile "7z.exe")-        dll = dir </> $(mkRelFile "7z.dll")-    case (siSevenzDll si, siSevenzExe si) of-        (Just sevenzDll, Just sevenzExe) -> do-            chattyDownload "7z.dll" sevenzDll dll-            chattyDownload "7z.exe" sevenzExe exe-            withRunInIO $ \run -> return $ \outdir archive -> liftIO $ run $ do-                let cmd = toFilePath exe-                    args =-                        [ "x"-                        , "-o" ++ toFilePath outdir-                        , "-y"-                        , toFilePath archive-                        ]-                ec <- proc cmd args runProcess-                when (ec /= ExitSuccess)-                    $ liftIO $ throwM (ProblemWhileDecompressing archive)-        _ -> throwM SetupInfoMissingSevenz--chattyDownload :: HasRunner env-               => Text          -- ^ label-               -> DownloadInfo  -- ^ URL, content-length, sha1, and sha256-               -> Path Abs File -- ^ destination-               -> RIO env ()-chattyDownload label downloadInfo path = do-    let url = downloadInfoUrl downloadInfo-    req <- parseUrlThrow $ T.unpack url-    logSticky $-      "Preparing to download " <>-      RIO.display label <>-      " ..."-    logDebug $-      "Downloading from " <>-      RIO.display url <>-      " to " <>-      fromString (toFilePath path) <>-      " ..."-    hashChecks <- fmap catMaybes $ forM-      [ ("sha1",   HashCheck SHA1,   downloadInfoSha1)-      , ("sha256", HashCheck SHA256, downloadInfoSha256)-      ]-      $ \(name, constr, getter) ->-        case getter downloadInfo of-          Just bs -> do-            logDebug $-                "Will check against " <>-                name <>-                " hash: " <>-                displayBytesUtf8 bs-            return $ Just $ constr $ CheckHexDigestByteString bs-          Nothing -> return Nothing-    when (null hashChecks) $ logWarn $-        "No sha1 or sha256 found in metadata," <>-        " download hash won't be checked."-    let dReq = DownloadRequest-            { drRequest = req-            , drHashChecks = hashChecks-            , drLengthCheck = mtotalSize-            , drRetryPolicy = drRetryPolicyDefault-            }-    x <- verifiedDownload dReq path chattyDownloadProgress-    if x-        then logStickyDone ("Downloaded " <> RIO.display label <> ".")-        else logStickyDone "Already downloaded."-  where-    mtotalSize = downloadInfoContentLength downloadInfo-    chattyDownloadProgress _ = do-        _ <- logSticky $ RIO.display label <> ": download has begun"-        CL.map (Sum . S.length)-          .| chunksOverTime 1-          .| go-      where-        go = evalStateC 0 $ awaitForever $ \(Sum size) -> do-            modify (+ size)-            totalSoFar <- get-            logSticky $ fromString $-                case mtotalSize of-                    Nothing -> chattyProgressNoTotal totalSoFar-                    Just 0 -> chattyProgressNoTotal totalSoFar-                    Just totalSize -> chattyProgressWithTotal totalSoFar totalSize--        -- Example: ghc: 42.13 KiB downloaded...-        chattyProgressNoTotal totalSoFar =-            printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...")-                   (T.unpack label)--        -- Example: ghc: 50.00 MiB / 100.00 MiB (50.00%) downloaded...-        chattyProgressWithTotal totalSoFar total =-          printf ("%s: " <>-                  bytesfmt "%7.2f" totalSoFar <> " / " <>-                  bytesfmt "%.2f" total <>-                  " (%6.2f%%) downloaded...")-                 (T.unpack label)-                 percentage-          where percentage :: Double-                percentage = fromIntegral totalSoFar / fromIntegral total * 100---- | Given a printf format string for the decimal part and a number of--- bytes, formats the bytes using an appropiate unit and returns the--- formatted string.------ >>> bytesfmt "%.2" 512368--- "500.359375 KiB"-bytesfmt :: Integral a => String -> a -> String-bytesfmt formatter bs = printf (formatter <> " %s")-                               (fromIntegral (signum bs) * dec :: Double)-                               (bytesSuffixes !! i)-  where-    (dec,i) = getSuffix (abs bs)-    getSuffix n = until p (\(x,y) -> (x / 1024, y+1)) (fromIntegral n,0)-      where p (n',numDivs) = n' < 1024 || numDivs == (length bytesSuffixes - 1)-    bytesSuffixes :: [String]-    bytesSuffixes = ["B","KiB","MiB","GiB","TiB","PiB","EiB","ZiB","YiB"]---- Await eagerly (collect with monoidal append),--- but space out yields by at least the given amount of time.--- The final yield may come sooner, and may be a superfluous mempty.--- Note that Integer and Float literals can be turned into NominalDiffTime--- (these literals are interpreted as "seconds")-chunksOverTime :: (Monoid a, Semigroup a, MonadIO m) => NominalDiffTime -> ConduitM a a m ()-chunksOverTime diff = do-    currentTime <- liftIO getCurrentTime-    evalStateC (currentTime, mempty) go-  where-    -- State is a tuple of:-    -- * the last time a yield happened (or the beginning of the sink)-    -- * the accumulated awaits since the last yield-    go = await >>= \case-      Nothing -> do-        (_, acc) <- get-        yield acc-      Just a -> do-        (lastTime, acc) <- get-        let acc' = acc <> a-        currentTime <- liftIO getCurrentTime-        if diff < diffUTCTime currentTime lastTime-          then put (currentTime, mempty) >> yield acc'-          else put (lastTime,    acc')-        go---- | Perform a basic sanity check of GHC-sanityCheck :: (HasProcessContext env, HasLogFunc env)-            => WhichCompiler-            -> RIO env ()-sanityCheck wc = withSystemTempDir "stack-sanity-check" $ \dir -> do-    let fp = toFilePath $ dir </> $(mkRelFile "Main.hs")-    liftIO $ S.writeFile fp $ T.encodeUtf8 $ T.pack $ unlines-        [ "import Distribution.Simple" -- ensure Cabal library is present-        , "main = putStrLn \"Hello World\""-        ]-    let exeName = compilerExeName wc-    ghc <- findExecutable exeName >>= either throwM parseAbsFile-    logDebug $ "Performing a sanity check on: " <> fromString (toFilePath ghc)-    eres <- withWorkingDir (toFilePath dir) $ proc exeName-        [ fp-        , "-no-user-package-db"-        ] $ try . readProcess_-    case eres of-        Left e -> throwIO $ GHCSanityCheckCompileFailed e ghc-        Right _ -> return () -- TODO check that the output of running the command is correct---- Remove potentially confusing environment variables-removeHaskellEnvVars :: Map Text Text -> Map Text Text-removeHaskellEnvVars =-    Map.delete "GHCJS_PACKAGE_PATH" .-    Map.delete "GHC_PACKAGE_PATH" .-    Map.delete "HASKELL_PACKAGE_SANDBOX" .-    Map.delete "HASKELL_PACKAGE_SANDBOXES" .-    Map.delete "HASKELL_DIST_DIR" .-    -- https://github.com/commercialhaskell/stack/issues/1460-    Map.delete "DESTDIR" .-    -- https://github.com/commercialhaskell/stack/issues/3444-    Map.delete "GHCRTS"---- | Get map of environment variables to set to change the GHC's encoding to UTF-8-getUtf8EnvVars-    :: (HasProcessContext env, HasPlatform env, HasLogFunc env)-    => CompilerVersion 'CVActual-    -> RIO env (Map Text Text)-getUtf8EnvVars compilerVer =-    if getGhcVersion compilerVer >= $(mkVersion "7.10.3")-        -- GHC_CHARENC supported by GHC >=7.10.3-        then return $ Map.singleton "GHC_CHARENC" "UTF-8"-        else legacyLocale-  where-    legacyLocale = do-        menv <- view processContextL-        Platform _ os <- view platformL-        if os == Cabal.Windows-            then-                 -- On Windows, locale is controlled by the code page, so we don't set any environment-                 -- variables.-                 return-                     Map.empty-            else do-                let checkedVars = map checkVar (Map.toList $ view envVarsL menv)-                    -- List of environment variables that will need to be updated to set UTF-8 (because-                    -- they currently do not specify UTF-8).-                    needChangeVars = concatMap fst checkedVars-                    -- Set of locale-related environment variables that have already have a value.-                    existingVarNames = Set.unions (map snd checkedVars)-                    -- True if a locale is already specified by one of the "global" locale variables.-                    hasAnyExisting =-                        any (`Set.member` existingVarNames) ["LANG", "LANGUAGE", "LC_ALL"]-                if null needChangeVars && hasAnyExisting-                    then-                         -- If no variables need changes and at least one "global" variable is set, no-                         -- changes to environment need to be made.-                         return-                             Map.empty-                    else do-                        -- Get a list of known locales by running @locale -a@.-                        elocales <- tryAny $ fmap fst $ proc "locale" ["-a"] readProcess_-                        let-                            -- Filter the list to only include locales with UTF-8 encoding.-                            utf8Locales =-                                case elocales of-                                    Left _ -> []-                                    Right locales ->-                                        filter-                                            isUtf8Locale-                                            (T.lines $-                                             T.decodeUtf8With-                                                 T.lenientDecode $-                                                 LBS.toStrict locales)-                            mfallback = getFallbackLocale utf8Locales-                        when-                            (isNothing mfallback)-                            (logWarn-                                 "Warning: unable to set locale to UTF-8 encoding; GHC may fail with 'invalid character'")-                        let-                            -- Get the new values of variables to adjust.-                            changes =-                                Map.unions $-                                map-                                    (adjustedVarValue menv utf8Locales mfallback)-                                    needChangeVars-                            -- Get the values of variables to add.-                            adds-                              | hasAnyExisting =-                                  -- If we already have a "global" variable, then nothing needs-                                  -- to be added.-                                  Map.empty-                              | otherwise =-                                  -- If we don't already have a "global" variable, then set LANG to the-                                  -- fallback.-                                  case mfallback of-                                      Nothing -> Map.empty-                                      Just fallback ->-                                          Map.singleton "LANG" fallback-                        return (Map.union changes adds)-    -- Determines whether an environment variable is locale-related and, if so, whether it needs to-    -- be adjusted.-    checkVar-        :: (Text, Text) -> ([Text], Set Text)-    checkVar (k,v) =-        if k `elem` ["LANG", "LANGUAGE"] || "LC_" `T.isPrefixOf` k-            then if isUtf8Locale v-                     then ([], Set.singleton k)-                     else ([k], Set.singleton k)-            else ([], Set.empty)-    -- Adjusted value of an existing locale variable.  Looks for valid UTF-8 encodings with-    -- same language /and/ territory, then with same language, and finally the first UTF-8 locale-    -- returned by @locale -a@.-    adjustedVarValue-        :: ProcessContext -> [Text] -> Maybe Text -> Text -> Map Text Text-    adjustedVarValue menv utf8Locales mfallback k =-        case Map.lookup k (view envVarsL menv) of-            Nothing -> Map.empty-            Just v ->-                case concatMap-                         (matchingLocales utf8Locales)-                         [ T.takeWhile (/= '.') v <> "."-                         , T.takeWhile (/= '_') v <> "_"] of-                    (v':_) -> Map.singleton k v'-                    [] ->-                        case mfallback of-                            Just fallback -> Map.singleton k fallback-                            Nothing -> Map.empty-    -- Determine the fallback locale, by looking for any UTF-8 locale prefixed with the list in-    -- @fallbackPrefixes@, and if not found, picking the first UTF-8 encoding returned by @locale-    -- -a@.-    getFallbackLocale-        :: [Text] -> Maybe Text-    getFallbackLocale utf8Locales =-        case concatMap (matchingLocales utf8Locales) fallbackPrefixes of-            (v:_) -> Just v-            [] ->-                case utf8Locales of-                    [] -> Nothing-                    (v:_) -> Just v-    -- Filter the list of locales for any with the given prefixes (case-insitive).-    matchingLocales-        :: [Text] -> Text -> [Text]-    matchingLocales utf8Locales prefix =-        filter (\v -> T.toLower prefix `T.isPrefixOf` T.toLower v) utf8Locales-    -- Does the locale have one of the encodings in @utf8Suffixes@ (case-insensitive)?-    isUtf8Locale locale =-      any (\ v -> T.toLower v `T.isSuffixOf` T.toLower locale) utf8Suffixes-    -- Prefixes of fallback locales (case-insensitive)-    fallbackPrefixes = ["C.", "en_US.", "en_"]-    -- Suffixes of UTF-8 locales (case-insensitive)-    utf8Suffixes = [".UTF-8", ".utf8"]---- Binary Stack upgrades--newtype StackReleaseInfo = StackReleaseInfo Value--downloadStackReleaseInfo :: (MonadIO m, MonadThrow 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 throwString $ "Could not get release information for Stack from: " ++ url--preferredPlatforms :: (MonadReader env m, HasPlatform env, MonadThrow m)-                   => m [(Bool, String)]-preferredPlatforms = do-    Platform arch' os' <- view platformL-    (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")-        _ -> throwM $ stringException $ "Binary upgrade not yet supported on OS: " ++ show os'-    arch <--      case arch' of-        I386 -> return "i386"-        X86_64 -> return "x86_64"-        Arm -> return "arm"-        _ -> throwM $ stringException $ "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-    :: HasConfig env-    => [(Bool, String)] -- ^ acceptable platforms-    -> StackReleaseInfo-    -> Path Abs Dir -- ^ destination directory-    -> Bool -- ^ perform PATH-aware checking, see #3232-    -> (Path Abs File -> IO ()) -- ^ test the temp exe before renaming-    -> RIO env ()-downloadStackExe platforms0 archiveInfo destDir checkPath testExe = do-    (isWindows, archiveURL) <--      let loop [] = throwString $ "Unable to find binary Stack archive for platforms: "-                                ++ unwords (map snd platforms0)-          loop ((isWindows, p'):ps) = do-            let p = T.pack p'-            logInfo $ "Querying for archive location for platform: " <> fromString 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: " <> RIO.display 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 <- view platformL--    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--    destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir-    warnInstallSearchPathIssues destDir' ["stack"]--    logInfo $ "New stack executable available at " <> fromString (toFilePath destFile)--    when checkPath $ performPathChecking destFile-      `catchAny` (logError . displayShow)-  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---- | Ensure that the Stack executable download is in the same location--- as the currently running executable. See:--- https://github.com/commercialhaskell/stack/issues/3232-performPathChecking-    :: HasConfig env-    => Path Abs File -- ^ location of the newly downloaded file-    -> RIO env ()-performPathChecking newFile = do-  executablePath <- liftIO getExecutablePath-  executablePath' <- parseAbsFile executablePath-  unless (toFilePath newFile == executablePath) $ do-    logInfo $ "Also copying stack executable to " <> fromString executablePath-    tmpFile <- parseAbsFile $ executablePath ++ ".tmp"-    eres <- tryIO $ do-      liftIO $ copyFile newFile tmpFile-#if !WINDOWS-      liftIO $ setFileMode (toFilePath tmpFile) 0o755-#endif-      liftIO $ renameFile tmpFile executablePath'-      logInfo "Stack executable copied successfully!"-    case eres of-      Right () -> return ()-      Left e-        | isPermissionError e -> do-            logWarn $ "Permission error when trying to copy: " <> displayShow e-            logWarn "Should I try to perform the file copy using sudo? This may fail"-            toSudo <- promptBool "Try using sudo? (y/n) "-            when toSudo $ do-              let run cmd args = do-                    ec <- proc cmd args runProcess-                    when (ec /= ExitSuccess) $ error $ concat-                          [ "Process exited with "-                          , show ec-                          , ": "-                          , unwords (cmd:args)-                          ]-                  commands =-                    [ ("sudo",-                        [ "cp"-                        , toFilePath newFile-                        , toFilePath tmpFile-                        ])-                    , ("sudo",-                        [ "mv"-                        , toFilePath tmpFile-                        , executablePath-                        ])-                    ]-              logInfo "Going to run the following commands:"-              logInfo ""-              forM_ commands $ \(cmd, args) ->-                logInfo $ "-  " <> mconcat (intersperse " " (fromString <$> (cmd:args)))-              mapM_ (uncurry run) commands-              logInfo ""-              logInfo "sudo file copy worked!"-        | otherwise -> throwM e--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+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiWayIf #-}++module Stack.Setup+  ( setupEnv+  , ensureCompilerAndMsys+  , ensureDockerStackExe+  , SetupOpts (..)+  , defaultSetupInfoYaml+  , withNewLocalBuildTargets++  -- * Stack binary download+  , StackReleaseInfo+  , getDownloadVersion+  , stackVersion+  , preferredPlatforms+  , downloadStackReleaseInfo+  , downloadStackExe+  ) where++import qualified    Codec.Archive.Tar as Tar+import              Conduit+import              Control.Applicative (empty)+import              Control.Monad.State (get, put, modify)+import "cryptonite" Crypto.Hash (SHA1(..), SHA256(..))+import              Pantry.Internal.AesonExtended+import qualified    Data.ByteString as S+import qualified    Data.ByteString.Lazy as LBS+import qualified    Data.Conduit.Binary as CB+import              Data.Conduit.Lazy (lazyConsume)+import              Data.Conduit.Lift (evalStateC)+import qualified    Data.Conduit.List as CL+import              Data.Conduit.Process.Typed (createSource)+import              Data.Conduit.Zlib          (ungzip)+import              Data.Foldable (maximumBy)+import qualified    Data.HashMap.Strict as HashMap+import              Data.List hiding (concat, elem, maximumBy, any)+import qualified    Data.Map as Map+import qualified    Data.Set as Set+import qualified    Data.Text as T+import qualified    Data.Text.Encoding as T+import qualified    Data.Text.Encoding.Error as T+import              Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)+import qualified    Data.Yaml as Yaml+import              Distribution.System (OS, Arch (..), Platform (..))+import qualified    Distribution.System as Cabal+import              Distribution.Text (simpleParse)+import              Distribution.Types.PackageName (mkPackageName)+import              Distribution.Version (mkVersion)+import              Lens.Micro (set)+import              Network.HTTP.StackClient (CheckHexDigest (..), DownloadRequest (..), HashCheck (..),+                                              drRetryPolicyDefault, getResponseBody, getResponseStatusCode,+                                              httpLbs, httpJSON, parseRequest, parseUrlThrow, setGithubHeaders,+                                              verifiedDownload, withResponse)+import              Path+import              Path.CheckInstall (warnInstallSearchPathIssues)+import              Path.Extra (toFilePathNoTrailingSep)+import              Path.IO hiding (findExecutable, withSystemTempDir)+import              Prelude (until)+import qualified    Pantry+import qualified    RIO+import              RIO.List+import              RIO.PrettyPrint+import              RIO.Process+import              Stack.Build.Haddock (shouldHaddockDeps)+import              Stack.Build.Source (loadSourceMap, hashSourceMapData)+import              Stack.Build.Target (NeedTargets(..), parseTargets)+import              Stack.Constants+import              Stack.Constants.Config (distRelativeDir)+import              Stack.GhcPkg (createDatabase, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar)+import              Stack.Prelude hiding (Display (..))+import              Stack.SourceMap+import              Stack.Setup.Installed+import              Stack.Storage (loadCompilerPaths, saveCompilerPaths)+import              Stack.Types.Build+import              Stack.Types.Compiler+import              Stack.Types.CompilerBuild+import              Stack.Types.Config+import              Stack.Types.Docker+import              Stack.Types.SourceMap+import              Stack.Types.Version+import qualified    System.Directory as D+import              System.Environment (getExecutablePath, lookupEnv)+import              System.IO.Error (isPermissionError)+import              System.FilePath (searchPathSeparator)+import qualified    System.FilePath as FP+import              System.Permissions (setFileExecutable)+import              Text.Printf (printf)+import              System.Uname (getRelease)+import              Data.List.Split (splitOn)++-- | Default location of the stack-setup.yaml file+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 :: !WantedCompiler+    , soptsCompilerCheck :: !VersionCheck+    , soptsStackYaml :: !(Maybe (Path Abs File))+    -- ^ If we got the desired GHC version from that file+    , soptsForceReinstall :: !Bool+    , soptsSanityCheck :: !Bool+    -- ^ Run a sanity check on the selected GHC+    , soptsSkipGhcCheck :: !Bool+    -- ^ Don't check for a compatible GHC version/architecture+    , soptsSkipMsys :: !Bool+    -- ^ Do not use a custom msys installation on Windows+    , soptsResolveMissingGHC :: !(Maybe Text)+    -- ^ Message shown to user for how to resolve the missing GHC+    , soptsSetupInfoYaml :: !FilePath+    -- ^ Location of the main stack-setup.yaml file+    , soptsGHCBindistURL :: !(Maybe String)+    -- ^ Alternate GHC binary distribution (requires custom GHCVariant)+    , soptsGHCJSBootOpts :: [String]+    -- ^ Additional ghcjs-boot options, the default is "--clean"+    }+    deriving Show+data SetupException = UnsupportedSetupCombo OS Arch+                    | MissingDependencies [String]+                    | UnknownCompilerVersion (Set.Set Text) WantedCompiler (Set.Set ActualCompiler)+                    | UnknownOSKey Text+                    | GHCSanityCheckCompileFailed SomeException (Path Abs File)+                    | WantedMustBeGHC+                    | RequireCustomGHCVariant+                    | ProblemWhileDecompressing (Path Abs File)+                    | SetupInfoMissingSevenz+                    | GHCJSRequiresStandardVariant+                    | GHCJSNotBooted+                    | DockerStackExeNotFound Version Text+                    | UnsupportedSetupConfiguration+                    | InvalidGhcAt (Path Abs File) SomeException+                    | NoLongerBuildGhcjs+    deriving Typeable+instance Exception SetupException+instance Show SetupException where+    show (UnsupportedSetupCombo os arch) = concat+        [ "I don't know how to install GHC for "+        , show (os, arch)+        , ", please install manually"+        ]+    show (MissingDependencies tools) =+        "The following executables are missing and must be installed: " +++        intercalate ", " tools+    show (UnknownCompilerVersion oskeys wanted known) = concat+        [ "No setup information found for "+        , T.unpack $ utf8BuilderToText $ RIO.display wanted+        , " on your platform.\nThis probably means a GHC bindist has not yet been added for OS key '"+        , T.unpack (T.intercalate "', '" (sort $ Set.toList oskeys))+        , "'.\nSupported versions: "+        , T.unpack (T.intercalate ", " (map compilerVersionText (sort $ Set.toList known)))+        ]+    show (UnknownOSKey oskey) =+        "Unable to find installation URLs for OS key: " +++        T.unpack oskey+    show (GHCSanityCheckCompileFailed e ghc) = concat+        [ "The GHC located at "+        , toFilePath ghc+        , " failed to compile a sanity check. Please see:\n\n"+        , "    http://docs.haskellstack.org/en/stable/install_and_upgrade/\n\n"+        , "for more information. Exception was:\n"+        , show e+        ]+    show WantedMustBeGHC =+        "The wanted compiler must be GHC"+    show RequireCustomGHCVariant =+        "A custom --ghc-variant must be specified to use --ghc-bindist"+    show (ProblemWhileDecompressing archive) =+        "Problem while decompressing " ++ toFilePath archive+    show SetupInfoMissingSevenz =+        "SetupInfo missing Sevenz EXE/DLL"+    show GHCJSRequiresStandardVariant =+        "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+        [ stackProgName+        , "-"+        , versionString stackVersion'+        , " executable not found for "+        , T.unpack osKey+        , "\nUse the '"+        , T.unpack dockerStackExeArgName+        , "' option to specify a location"]+    show UnsupportedSetupConfiguration =+        "I don't know how to install GHC on your system configuration, please install manually"+    show (InvalidGhcAt compiler e) =+        "Found an invalid compiler at " ++ show (toFilePath compiler) ++ ": " ++ displayException e+    show NoLongerBuildGhcjs =+        "Since Stack 2.0, Stack does not support building GHCJS itself"++-- | Modify the environment variables (like PATH) appropriately, possibly doing installation too+setupEnv :: NeedTargets+         -> BuildOptsCLI+         -> Maybe Text -- ^ Message to give user when necessary GHC is not available+         -> RIO BuildConfig EnvConfig+setupEnv needTargets boptsCLI mResolveMissingGHC = do+    config <- view configL+    bc <- view buildConfigL+    let stackYaml = bcStackYaml bc+    platform <- view platformL+    wcVersion <- view wantedCompilerVersionL+    wc <- view $ wantedCompilerVersionL.to wantedToActual.whichCompilerL+    let sopts = SetupOpts+            { soptsInstallIfMissing = configInstallGHC config+            , soptsUseSystem = configSystemGHC config+            , soptsWantedCompiler = wcVersion+            , soptsCompilerCheck = configCompilerCheck config+            , soptsStackYaml = Just stackYaml+            , soptsForceReinstall = False+            , soptsSanityCheck = False+            , soptsSkipGhcCheck = configSkipGHCCheck config+            , soptsSkipMsys = configSkipMsys config+            , soptsResolveMissingGHC = mResolveMissingGHC+            , soptsSetupInfoYaml = defaultSetupInfoYaml+            , soptsGHCBindistURL = Nothing+            , soptsGHCJSBootOpts = ["--clean"]+            }++    (compilerPaths, ghcBin) <- ensureCompilerAndMsys sopts+    let compilerVer = cpCompilerVersion compilerPaths++    -- Modify the initial environment to include the GHC path, if a local GHC+    -- is being used+    menv0 <- view processContextL+    env <- either throwM (return . removeHaskellEnvVars)+               $ augmentPathMap+                    (map toFilePath $ edBins ghcBin)+                    (view envVarsL menv0)+    menv <- mkProcessContext env++    logDebug "Resolving package entries"++    (sourceMap, sourceMapHash) <- runWithGHC menv compilerPaths $ do+      smActual <- actualFromGhc (bcSMWanted bc) compilerVer+      let actualPkgs = Map.keysSet (smaDeps smActual) <>+                       Map.keysSet (smaProject smActual)+          prunedActual = smActual { smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs }+          haddockDeps = shouldHaddockDeps (configBuild config)+      targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual+      sourceMap <- loadSourceMap targets boptsCLI smActual+      sourceMapHash <- hashSourceMapData boptsCLI sourceMap+      pure (sourceMap, sourceMapHash)++    let envConfig0 = EnvConfig+            { envConfigBuildConfig = bc+            , envConfigBuildOptsCLI = boptsCLI+            , envConfigSourceMap = sourceMap+            , envConfigSourceMapHash = sourceMapHash+            , envConfigCompilerPaths = compilerPaths+            }++    -- extra installation bin directories+    mkDirs <- runRIO envConfig0 extraBinDirs+    let mpath = Map.lookup "PATH" env+    depsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs False) mpath+    localsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs True) mpath++    deps <- runRIO envConfig0 packageDatabaseDeps+    runWithGHC menv compilerPaths $ createDatabase (cpPkg compilerPaths) deps+    localdb <- runRIO envConfig0 packageDatabaseLocal+    runWithGHC menv compilerPaths $ createDatabase (cpPkg compilerPaths) localdb+    extras <- runReaderT packageDatabaseExtra envConfig0+    let mkGPP locals = mkGhcPackagePath locals localdb deps extras $ cpGlobalDB compilerPaths++    distDir <- runReaderT distRelativeDir envConfig0 >>= canonicalizePath++    executablePath <- liftIO getExecutablePath++    utf8EnvVars <- withProcessContext menv $ getUtf8EnvVars compilerVer++    mGhcRtsEnvVar <- liftIO $ lookupEnv "GHCRTS"++    envRef <- liftIO $ newIORef Map.empty+    let getProcessContext' es = do+            m <- readIORef envRef+            case Map.lookup es m of+                Just eo -> return eo+                Nothing -> do+                    eo <- mkProcessContext+                        $ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath)+                        $ (if esIncludeGhcPackagePath es+                                then Map.insert (ghcPkgPathEnvVar wc) (mkGPP (esIncludeLocals es))+                                else id)++                        $ (if esStackExe es+                                then Map.insert "STACK_EXE" (T.pack executablePath)+                                else id)++                        $ (if esLocaleUtf8 es+                                then Map.union utf8EnvVars+                                else id)++                        $ case (soptsSkipMsys sopts, platform) of+                            (False, Platform Cabal.I386   Cabal.Windows)+                                -> Map.insert "MSYSTEM" "MINGW32"+                            (False, Platform Cabal.X86_64 Cabal.Windows)+                                -> Map.insert "MSYSTEM" "MINGW64"+                            _   -> id++                        -- See https://github.com/commercialhaskell/stack/issues/3444+                        $ case (esKeepGhcRts es, mGhcRtsEnvVar) of+                            (True, Just ghcRts) -> Map.insert "GHCRTS" (T.pack ghcRts)+                            _ -> id++                        -- For reasoning and duplication, see: https://github.com/fpco/stack/issues/70+                        $ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePathNoTrailingSep deps)+                        $ Map.insert "HASKELL_PACKAGE_SANDBOXES"+                            (T.pack $ if esIncludeLocals es+                                then intercalate [searchPathSeparator]+                                        [ toFilePathNoTrailingSep localdb+                                        , toFilePathNoTrailingSep deps+                                        , ""+                                        ]+                                else intercalate [searchPathSeparator]+                                        [ toFilePathNoTrailingSep deps+                                        , ""+                                        ])+                        $ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSep distDir)++                          -- Make sure that any .ghc.environment files+                          -- are ignored, since we're settting up our+                          -- own package databases. See+                          -- https://github.com/commercialhaskell/stack/issues/4706+                        $ (case cpCompilerVersion compilerPaths of+                             ACGhc version | version >= mkVersion [8, 4, 4] ->+                               Map.insert "GHC_ENVIRONMENT" "-"+                             _ -> id)++                          env++                    () <- atomicModifyIORef envRef $ \m' ->+                        (Map.insert es eo m', ())+                    return eo++    envOverride <- liftIO $ getProcessContext' minimalEnvSettings+    return EnvConfig+        { envConfigBuildConfig = bc+            { bcConfig = addIncludeLib ghcBin+                       $ set processContextL envOverride+                         (view configL bc)+                { configProcessContextSettings = getProcessContext'+                }+            }+        , envConfigBuildOptsCLI = boptsCLI+        , envConfigSourceMap = sourceMap+        , envConfigSourceMapHash = sourceMapHash+        , envConfigCompilerPaths = compilerPaths+        }++-- | A modified env which we know has an installed compiler on the PATH.+data WithGHC env = WithGHC !CompilerPaths !env++insideL :: Lens' (WithGHC env) env+insideL = lens (\(WithGHC _ x) -> x) (\(WithGHC cp _) -> WithGHC cp)++instance HasLogFunc env => HasLogFunc (WithGHC env) where+  logFuncL = insideL.logFuncL+instance HasRunner env => HasRunner (WithGHC env) where+  runnerL = insideL.runnerL+instance HasProcessContext env => HasProcessContext (WithGHC env) where+  processContextL = insideL.processContextL+instance HasStylesUpdate env => HasStylesUpdate (WithGHC env) where+  stylesUpdateL = insideL.stylesUpdateL+instance HasTerm env => HasTerm (WithGHC env) where+  useColorL = insideL.useColorL+  termWidthL = insideL.termWidthL+instance HasPantryConfig env => HasPantryConfig (WithGHC env) where+  pantryConfigL = insideL.pantryConfigL+instance HasConfig env => HasPlatform (WithGHC env)+instance HasConfig env => HasGHCVariant (WithGHC env)+instance HasConfig env => HasConfig (WithGHC env) where+  configL = insideL.configL+instance HasBuildConfig env => HasBuildConfig (WithGHC env) where+  buildConfigL = insideL.buildConfigL+instance HasCompiler (WithGHC env) where+  compilerPathsL = to (\(WithGHC cp _) -> cp)++-- | Set up a modified environment which includes the modified PATH+-- that GHC can be found on. This is needed for looking up global+-- package information and ghc fingerprint (result from 'ghc --info').+runWithGHC :: HasConfig env => ProcessContext -> CompilerPaths -> RIO (WithGHC env) a -> RIO env a+runWithGHC pc cp inner = do+  env <- ask+  let envg+        = WithGHC cp $+          set envOverrideSettingsL (\_ -> return pc) $+          set processContextL pc env+  runRIO envg inner++-- | special helper for GHCJS which needs an updated source map+-- only project dependencies should get included otherwise source map hash will+-- get changed and EnvConfig will become inconsistent+rebuildEnv :: EnvConfig+    -> NeedTargets+    -> Bool+    -> BuildOptsCLI+    -> RIO env EnvConfig+rebuildEnv envConfig needTargets haddockDeps boptsCLI = do+    let bc = envConfigBuildConfig envConfig+        cp = envConfigCompilerPaths envConfig+        compilerVer = smCompiler $ envConfigSourceMap envConfig+    runRIO (WithGHC cp bc) $ do+        smActual <- actualFromGhc (bcSMWanted bc) compilerVer+        let actualPkgs = Map.keysSet (smaDeps smActual) <> Map.keysSet (smaProject smActual)+            prunedActual = smActual {+              smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs+              }+        targets <- parseTargets needTargets haddockDeps boptsCLI prunedActual+        sourceMap <- loadSourceMap targets boptsCLI smActual+        return $+            envConfig+            {envConfigSourceMap = sourceMap, envConfigBuildOptsCLI = boptsCLI}++-- | Some commands (script, ghci and exec) set targets dynamically+-- see also the note about only local targets for rebuildEnv+withNewLocalBuildTargets :: HasEnvConfig  env => [Text] -> RIO env a -> RIO env a+withNewLocalBuildTargets targets f = do+    envConfig <- view $ envConfigL+    haddockDeps <- view $ configL.to configBuild.to shouldHaddockDeps+    let boptsCLI = envConfigBuildOptsCLI envConfig+    envConfig' <- rebuildEnv envConfig NeedTargets haddockDeps $+                  boptsCLI {boptsCLITargets = targets}+    local (set envConfigL envConfig') f++-- | Add the include and lib paths to the given Config+addIncludeLib :: ExtraDirs -> Config -> Config+addIncludeLib (ExtraDirs _bins includes libs) config = config+    { configExtraIncludeDirs =+        configExtraIncludeDirs config +++        map toFilePathNoTrailingSep includes+    , configExtraLibDirs =+        configExtraLibDirs config +++        map toFilePathNoTrailingSep libs+    }++-- | Ensure both the compiler and the msys toolchain are installed and+-- provide the PATHs to add if necessary+ensureCompilerAndMsys+  :: (HasConfig env, HasGHCVariant env)+  => SetupOpts+  -> RIO env (CompilerPaths, ExtraDirs)+ensureCompilerAndMsys sopts = do+  didWarn <- warnUnsupportedCompiler $ getGhcVersion $ wantedToActual $ soptsWantedCompiler sopts++  getSetupInfo' <- memoizeRef (getSetupInfo (soptsSetupInfoYaml sopts))+  (cp, ghcPaths) <- ensureCompiler sopts getSetupInfo'++  warnUnsupportedCompilerCabal cp didWarn++  mmsys2Tool <- ensureMsys sopts getSetupInfo'+  paths <-+    case mmsys2Tool of+      Nothing -> pure ghcPaths+      Just msys2Tool -> do+        msys2Paths <- extraDirs msys2Tool+        pure $ ghcPaths <> msys2Paths+  pure (cp, paths)++-- | See <https://github.com/commercialhaskell/stack/issues/4246>+warnUnsupportedCompiler :: HasLogFunc env => Version -> RIO env Bool+warnUnsupportedCompiler ghcVersion = do+  if+    | ghcVersion < mkVersion [7, 8] -> do+        logWarn $+          "Stack will almost certainly fail with GHC below version 7.8, requested " <>+          fromString (versionString ghcVersion)+        logWarn "Valiantly attempting to run anyway, but I know this is doomed"+        logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648"+        logWarn ""+        pure True+    | ghcVersion >= mkVersion [8, 7] -> do+        logWarn $+          "Stack has not been tested with GHC versions above 8.6, and using " <>+          fromString (versionString ghcVersion) <>+          ", this may fail"+        pure True+    | otherwise -> do+        logDebug "Asking for a supported GHC version"+        pure False++-- | See <https://github.com/commercialhaskell/stack/issues/4246>+warnUnsupportedCompilerCabal+  :: HasLogFunc env+  => CompilerPaths+  -> Bool -- ^ already warned about GHC?+  -> RIO env ()+warnUnsupportedCompilerCabal cp didWarn = do+  unless didWarn $ void $ warnUnsupportedCompiler $ getGhcVersion $ cpCompilerVersion cp+  let cabalVersion = cpCabalVersion cp++  if+    | cabalVersion < mkVersion [1, 19, 2] -> do+        logWarn $ "Stack no longer supported Cabal versions below 1.19.2,"+        logWarn $ "but version " <> fromString (versionString cabalVersion) <> "was found."+        logWarn "This invocation will most likely fail."+        logWarn "To fix this, either use a newer version of Stack or a newer resolver"+        logWarn "Acceptable resolvers: lts-3.0/nightly-2015-05-05 or later"+    | cabalVersion >= mkVersion [2, 5] ->+        logWarn $+          "Stack has not been tested with Cabal versions above 2.4, but version " <>+          fromString (versionString cabalVersion) <>+          " was found, this may fail"+    | otherwise -> pure ()++-- | Ensure that the msys toolchain is installed if necessary and+-- provide the PATHs to add if necessary+ensureMsys+  :: HasConfig env+  => SetupOpts+  -> Memoized SetupInfo+  -> RIO env (Maybe Tool)+ensureMsys sopts getSetupInfo' = do+  platform <- view platformL+  localPrograms <- view $ configL.to configLocalPrograms+  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 <- runMemoized getSetupInfo'+                      osKey <- getOSKey platform+                      config <- view configL+                      VersionedDownloadInfo version info <-+                          case Map.lookup osKey $ siMsys2 si of+                              Just x -> return x+                              Nothing -> throwString $ "MSYS2 not found for " ++ T.unpack osKey+                      let tool = Tool (PackageIdentifier (mkPackageName "msys2") version)+                      Just <$> downloadAndInstallTool (configLocalPrograms config) info tool (installMsys2Windows osKey si)+                  | otherwise -> do+                      logWarn "Continuing despite missing tool: msys2"+                      return Nothing+      _ -> return Nothing++installGhcBindist+  :: HasConfig env+  => SetupOpts+  -> Memoized SetupInfo+  -> [Tool]+  -> RIO env (Tool, CompilerBuild)+installGhcBindist sopts getSetupInfo' installed = do+    Platform expectedArch _ <- view platformL+    let wanted = soptsWantedCompiler sopts+        isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)+    config <- view configL+    ghcVariant <- view ghcVariantL+    possibleCompilers <-+            case whichCompiler $ wantedToActual wanted of+                Ghc -> do+                    ghcBuilds <- getGhcBuilds+                    forM ghcBuilds $ \ghcBuild -> do+                        ghcPkgName <- parsePackageNameThrowing ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)+                        return (getInstalledTool installed ghcPkgName (isWanted . ACGhc), ghcBuild)+                Ghcjs -> return []+    let existingCompilers = concatMap+            (\(installedCompiler, compilerBuild) ->+                case (installedCompiler, soptsForceReinstall sopts) of+                    (Just tool, False) -> [(tool, compilerBuild)]+                    _ -> [])+            possibleCompilers+    logDebug $+      "Found already installed GHC builds: " <>+      mconcat (intersperse ", " (map (fromString . compilerBuildName . snd) existingCompilers))+    case existingCompilers of+        (tool, build_):_ -> return (tool, build_)+        []+            | soptsInstallIfMissing sopts -> do+                si <- runMemoized getSetupInfo'+                downloadAndInstallPossibleCompilers+                    (map snd possibleCompilers)+                    si+                    (soptsWantedCompiler sopts)+                    (soptsCompilerCheck sopts)+                    (soptsGHCBindistURL sopts)+            | otherwise -> do+                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."+                             ])+                        (soptsResolveMissingGHC sopts)+                throwM $ CompilerVersionMismatch+                    Nothing -- FIXME ((\(x, y, _) -> (x, y)) <$> msystem)+                    (soptsWantedCompiler sopts, expectedArch)+                    ghcVariant+                    (case possibleCompilers of+                        [] -> CompilerBuildStandard+                        (_, compilerBuild):_ -> compilerBuild)+                    (soptsCompilerCheck sopts)+                    (soptsStackYaml sopts)+                    suggestion++-- | Ensure compiler (ghc or ghcjs) is installed, without worrying about msys+ensureCompiler+  :: forall env. (HasConfig env, HasGHCVariant env)+  => SetupOpts+  -> Memoized SetupInfo+  -> RIO env (CompilerPaths, ExtraDirs)+ensureCompiler sopts getSetupInfo' = do+    let wanted = soptsWantedCompiler sopts+        wc = whichCompiler $ wantedToActual wanted++    Platform expectedArch _ <- view platformL++    let canUseCompiler cp+            | soptsSkipGhcCheck sopts = pure cp+            | not $ isWanted $ cpCompilerVersion cp = throwString "Not the compiler version we want"+            | cpArch cp /= expectedArch = throwString "Not the architecture we want"+            | otherwise = pure cp+        isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)++    let checkCompiler :: Path Abs File -> RIO env (Maybe CompilerPaths)+        checkCompiler compiler = do+          eres <- tryAny $ pathsFromCompiler wc CompilerBuildStandard False compiler >>= canUseCompiler+          case eres of+            Left e -> do+              logDebug $ "Not using compiler at " <> displayShow (toFilePath compiler) <> ": " <> displayShow e+              pure Nothing+            Right cp -> pure $ Just cp++    mcp <-+        if soptsUseSystem sopts+            then do+                logDebug "Getting system compiler version"+                runConduit $+                  sourceSystemCompilers wanted .|+                  concatMapMC checkCompiler .|+                  await+            else return Nothing+    case mcp of+      Nothing -> ensureSandboxedCompiler sopts getSetupInfo'+      Just cp -> do+        let paths = ExtraDirs { edBins = [parent $ cpCompiler cp], edInclude = [], edLib = [] }+        pure (cp, paths)++ensureSandboxedCompiler+  :: HasConfig env+  => SetupOpts+  -> Memoized SetupInfo+  -> RIO env (CompilerPaths, ExtraDirs)+ensureSandboxedCompiler sopts getSetupInfo' = do+    let wanted = soptsWantedCompiler sopts+    -- List installed tools+    config <- view configL+    let localPrograms = configLocalPrograms config+    installed <- listInstalled localPrograms+    logDebug $ "Installed tools: \n - " <> mconcat (intersperse "\n - " (map (fromString . toolString) installed))+    (compilerTool, compilerBuild) <-+      case soptsWantedCompiler sopts of+       -- shall we build GHC from source?+       WCGhcGit commitId flavour -> buildGhcFromSource getSetupInfo' installed  (configCompilerRepository config) commitId flavour+       _ -> installGhcBindist sopts getSetupInfo' installed+    paths <- extraDirs compilerTool++    let wc = whichCompiler $ wantedToActual wanted+    menv0 <- view processContextL+    m <- either throwM return+       $ augmentPathMap (toFilePath <$> edBins paths) (view envVarsL menv0)+    menv <- mkProcessContext (removeHaskellEnvVars m)++    let names =+          case wanted of+            WCGhc version -> ["ghc-" ++ versionString version, "ghc"]+            WCGhcGit{} -> ["ghc"]+            WCGhcjs{} -> ["ghcjs"]+        loop [] = do+          logError $ "Looked for sandboxed compiler named one of: " <> displayShow names+          logError $ "Could not find it on the paths " <> displayShow (edBins paths)+          throwString "Could not find sandboxed compiler"+        loop (x:xs) = do+          res <- findExecutable x+          case res of+            Left _ -> loop xs+            Right y -> parseAbsFile y+    compiler <- withProcessContext menv $ loop names++    when (soptsSanityCheck sopts) $ sanityCheck compiler+    cp <- pathsFromCompiler wc compilerBuild True compiler+    pure (cp, paths)++pathsFromCompiler+  :: forall env. HasConfig env+  => WhichCompiler+  -> CompilerBuild+  -> Bool+  -> Path Abs File -- ^ executable filepath+  -> RIO env CompilerPaths+pathsFromCompiler wc compilerBuild isSandboxed compiler = withCache $ handleAny onErr $ do+    let dir = toFilePath $ parent compiler+        suffixNoVersion+          | osIsWindows = ".exe"+          | otherwise = ""+        msuffixWithVersion = do+          let prefix =+                case wc of+                  Ghc -> "ghc-"+                  Ghcjs -> "ghcjs-"+          fmap ("-" ++) $ stripPrefix prefix $ toFilePath $ filename compiler+        suffixes = maybe id (:) msuffixWithVersion [suffixNoVersion]+        findHelper :: (WhichCompiler -> [String]) -> RIO env (Path Abs File)+        findHelper getNames = do+          let toTry = [dir ++ name ++ suffix | suffix <- suffixes, name <- getNames wc]+              loop [] = throwString $ "Could not find any of: " <> show toTry+              loop (guessedPath':rest) = do+                guessedPath <- parseAbsFile guessedPath'+                exists <- doesFileExist guessedPath+                if exists+                  then pure guessedPath+                  else loop rest+          logDebug $ "Looking for executable(s): " <> displayShow toTry+          loop toTry+    pkg <- fmap GhcPkgExe $ findHelper $ \case+                               Ghc -> ["ghc-pkg"]+                               Ghcjs -> ["ghcjs-pkg"]++    menv0 <- view processContextL+    menv <- mkProcessContext (removeHaskellEnvVars (view envVarsL menv0))++    interpreter <- findHelper $+                   \case+                      Ghc -> ["runghc"]+                      Ghcjs -> ["runghcjs"]+    haddock <- findHelper $+               \case+                  Ghc -> ["haddock", "haddock-ghc"]+                  Ghcjs -> ["haddock-ghcjs"]+    infobs <- proc (toFilePath compiler) ["--info"]+            $ fmap (toStrictBytes . fst) . readProcess_+    infotext <-+      case decodeUtf8' infobs of+        Left e -> throwString $ "GHC info is not valid UTF-8: " ++ show e+        Right info -> pure info+    infoPairs :: [(String, String)] <-+      case readMaybe $ T.unpack infotext of+        Nothing -> throwString "GHC info does not parse as a list of pairs"+        Just infoPairs -> pure infoPairs+    let infoMap = Map.fromList infoPairs++    eglobaldb <- tryAny $+      case Map.lookup "Global Package DB" infoMap of+        Nothing -> throwString "Key 'Global Package DB' not found in GHC info"+        Just db -> parseAbsDir db++    arch <-+      case Map.lookup "Target platform" infoMap of+        Nothing -> throwString "Key 'Target platform' not found in GHC info"+        Just targetPlatform ->+          case simpleParse $ takeWhile (/= '-') targetPlatform of+            Nothing -> throwString $ "Invalid target platform in GHC info: " ++ show targetPlatform+            Just arch -> pure arch+    compilerVer <-+      case wc of+        Ghc ->+          case Map.lookup "Project version" infoMap of+            Nothing -> do+              logWarn "Key 'Project version' not found in GHC info"+              getCompilerVersion wc compiler+            Just versionString' -> ACGhc <$> parseVersionThrowing versionString'+        Ghcjs -> getCompilerVersion wc compiler+    globaldb <-+      case eglobaldb of+        Left e -> do+          logWarn "Parsing global DB from GHC info failed"+          logWarn $ displayShow e+          logWarn "Asking ghc-pkg directly"+          withProcessContext menv $ getGlobalDB pkg+        Right x -> pure x++    globalDump <- withProcessContext menv $ globalsFromDump pkg+    cabalPkgVer <-+      case Map.lookup cabalPackageName globalDump of+        Nothing -> throwString $ "Cabal library not found in global package database for " ++ toFilePath compiler+        Just dp -> pure $ pkgVersion $ dpPackageIdent dp++    return CompilerPaths+      { cpBuild = compilerBuild+      , cpArch = arch+      , cpSandboxed = isSandboxed+      , cpCompilerVersion = compilerVer+      , cpCompiler = compiler+      , cpPkg = pkg+      , cpInterpreter = interpreter+      , cpHaddock = haddock+      , cpCabalVersion = cabalPkgVer+      , cpGlobalDB = globaldb+      , cpGhcInfo = infobs+      , cpGlobalDump = globalDump+      }+  where+    onErr = throwIO . InvalidGhcAt compiler++    withCache inner = do+      eres <- tryAny $ loadCompilerPaths compiler compilerBuild isSandboxed+      mres <-+        case eres of+          Left e -> do+            logWarn $ "Trouble loading CompilerPaths cache: " <> displayShow e+            pure Nothing+          Right x -> pure x+      case mres of+        Just cp -> cp <$ logDebug "Loaded compiler information from cache"+        Nothing -> do+          cp <- inner+          saveCompilerPaths cp `catchAny` \e ->+            logWarn ("Unable to save CompilerPaths cache: " <> displayShow e)+          pure cp++buildGhcFromSource :: forall env.+   ( HasTerm env+   , HasProcessContext env+   , HasConfig env+   ) => Memoized SetupInfo -> [Tool] -> CompilerRepository -> Text -> Text+   -> RIO env (Tool, CompilerBuild)+buildGhcFromSource getSetupInfo' installed (CompilerRepository url) commitId flavour = do+   config <- view configL+   let compilerTool = ToolGhcGit commitId flavour++   -- detect when the correct GHC is already installed+   if compilerTool `elem` installed+     then return (compilerTool,CompilerBuildStandard)+     else do+       let repo = Repo+            { repoCommit = commitId+            , repoUrl    = url+            , repoType   = RepoGit+            , repoSubdir = mempty+            }++       -- clone the repository and execute the given commands+       Pantry.withRepo repo $ do+         -- withRepo is guaranteed to set workingDirL, so let's get it+         mcwd <- traverse parseAbsDir =<< view workingDirL+         let cwd = fromMaybe (error "Invalid working directory") mcwd++         threads <- view $ configL.to configJobs+         let+           hadrianArgs = fmap T.unpack+               [ "-c"                    -- run ./boot and ./configure+               , "-j" <> tshow threads   -- parallel build+               , "--flavour=" <> flavour -- selected flavour+               , "binary-dist"+               ]+           hadrianCmd+             | osIsWindows = hadrianCmdWindows+             | otherwise   = hadrianCmdPosix++         logSticky $ "Building GHC from source with `"+            <> RIO.display flavour+            <> "` flavour. It can take a long time (more than one hour)..."++         -- We need to provide an absolute path to the script since+         -- the process package only sets working directory _after_+         -- discovering the executable+         proc (toFilePath (cwd </> hadrianCmd)) hadrianArgs runProcess_++         -- find the bindist and install it+         bindistPath <- parseRelDir "_build/bindist"+         (_,files) <- listDir (cwd </> bindistPath)+         let+           isBindist p = "ghc-" `isPrefixOf` (toFilePath (filename p))+                         && fileExtension (filename p) == ".xz"+           mbindist = filter isBindist files+         case mbindist of+           [bindist] -> do+               let bindist' = T.pack (toFilePath bindist)+                   dlinfo = DownloadInfo+                             { downloadInfoUrl           = bindist'+                               -- we can specify a filepath instead of a URL+                             , downloadInfoContentLength = Nothing+                             , downloadInfoSha1          = Nothing+                             , downloadInfoSha256        = Nothing+                             }+                   ghcdlinfo = GHCDownloadInfo mempty mempty dlinfo+                   installer+                      | osIsWindows = installGHCWindows Nothing+                      | otherwise   = installGHCPosix Nothing ghcdlinfo+               si <- runMemoized getSetupInfo'+               _ <- downloadAndInstallTool+                 (configLocalPrograms config)+                 dlinfo+                 compilerTool+                 (installer si)+               return (compilerTool, CompilerBuildStandard)+           _ -> do+              forM_ files (logDebug . fromString . (" - " ++) . toFilePath)+              error "Can't find hadrian generated bindist"+++-- | Determine which GHC builds to use depending on which shared libraries are available+-- on the system.+getGhcBuilds :: HasConfig env => RIO env [CompilerBuild]+getGhcBuilds = do++    config <- view configL+    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 <- view platformL+        case platform of+            Platform _ Cabal.Linux -> do+                -- Some systems don't have ldconfig in the PATH, so make sure to look in /sbin and /usr/sbin as well+                let sbinEnv m = Map.insert+                      "PATH"+                      ("/sbin:/usr/sbin" <> maybe "" (":" <>) (Map.lookup "PATH" m))+                      m+                eldconfigOut+                  <- withModifyEnvVars sbinEnv+                   $ proc "ldconfig" ["-p"]+                   $ tryAny . fmap fst . readProcess_+                let firstWords = case eldconfigOut of+                        Right ldconfigOut -> mapMaybe (listToMaybe . T.words) $+                            T.lines $ T.decodeUtf8With T.lenientDecode+                                    $ LBS.toStrict ldconfigOut+                        Left _ -> []+                    checkLib lib+                        | libT `elem` firstWords = do+                            logDebug ("Found shared library " <> libD <> " in 'ldconfig -p' output")+                            return True+                        | osIsWindows =+                            -- Cannot parse /usr/lib on Windows+                            return False+                        | otherwise = do+                        -- This is a workaround for the fact that libtinfo.so.x doesn't appear in+                        -- the 'ldconfig -p' output on Arch or Slackware 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 cases.+                            matches <- filterM (doesFileExist .(</> lib)) usrLibDirs+                            case matches of+                                [] -> logDebug ("Did not find shared library " <> libD)+                                    >> return False+                                (path:_) -> logDebug ("Found shared library " <> libD+                                        <> " in " <> fromString (Path.toFilePath path))+                                    >> return True+                      where+                        libT = T.pack (toFilePath lib)+                        libD = fromString (toFilePath lib)+                hastinfo5 <- checkLib relFileLibtinfoSo5+                hastinfo6 <- checkLib relFileLibtinfoSo6+                hasncurses6 <- checkLib relFileLibncurseswSo6+                hasgmp5 <- checkLib relFileLibgmpSo10+                hasgmp4 <- checkLib relFileLibgmpSo3+                let libComponents = concat+                        [ [["tinfo6"] | hastinfo6 && hasgmp5]+                        , [[] | hastinfo5 && hasgmp5]+                        , [["ncurses6"] | hasncurses6 && hasgmp5 ]+                        , [["gmp4"] | hasgmp4 ]+                        ]+                useBuilds $ map+                    (\c -> case c of+                        [] -> CompilerBuildStandard+                        _ -> CompilerBuildSpecialized (intercalate "-" c))+                    libComponents+            Platform _ Cabal.FreeBSD -> do+                let getMajorVer = readMaybe <=< headMaybe . (splitOn ".")+                majorVer <- getMajorVer <$> sysRelease+                if majorVer >= Just (12 :: Int) then+                  useBuilds [CompilerBuildSpecialized "ino64"]+                else+                  useBuilds [CompilerBuildStandard]+            Platform _ Cabal.OpenBSD -> do+                releaseStr <- mungeRelease <$> sysRelease+                useBuilds [CompilerBuildSpecialized releaseStr]+            _ -> useBuilds [CompilerBuildStandard]+    useBuilds builds = do+        logDebug $+          "Potential GHC builds: " <>+          mconcat (intersperse ", " (map (fromString . compilerBuildName) builds))+        return builds++-- | Encode an OpenBSD version (like "6.1") into a valid argument for+-- CompilerBuildSpecialized, so "maj6-min1". Later version numbers are prefixed+-- with "r".+-- The result r must be such that "ghc-" ++ r is a valid package name,+-- as recognized by parsePackageNameFromString.+mungeRelease :: String -> String+mungeRelease = intercalate "-" . prefixMaj . splitOn "."+  where+    prefixFst pfx k (rev : revs) = (pfx ++ rev) : k revs+    prefixFst _ _ [] = []+    prefixMaj = prefixFst "maj" prefixMin+    prefixMin = prefixFst "min" (map ('r':))++sysRelease :: HasLogFunc env => RIO env String+sysRelease =+  handleIO (\e -> do+               logWarn $ "Could not query OS version: " <> displayShow e+               return "")+  (liftIO getRelease)++-- | Ensure Docker container-compatible 'stack' executable is downloaded+ensureDockerStackExe :: HasConfig env => Platform -> RIO env (Path Abs File)+ensureDockerStackExe containerPlatform = do+    config <- view configL+    containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone)+    let programsPath = configLocalProgramsBase config </> containerPlatformDir+        tool = Tool (PackageIdentifier (mkPackageName "stack") stackVersion)+    stackExeDir <- installDir programsPath tool+    let stackExePath = stackExeDir </> relFileStack+    stackExeExists <- doesFileExist stackExePath+    unless stackExeExists $ do+        logInfo $+          "Downloading Docker-compatible " <>+          fromString stackProgName <>+          " executable"+        sri <- downloadStackReleaseInfo Nothing Nothing (Just (versionString stackMinorVersion))+        platforms <- runReaderT preferredPlatforms (containerPlatform, PlatformVariantNone)+        downloadStackExe platforms sri stackExeDir False (const $ return ())+    return stackExePath++-- | Get all executables on the path that might match the wanted compiler+sourceSystemCompilers+  :: (HasProcessContext env, HasLogFunc env)+  => WantedCompiler+  -> ConduitT i (Path Abs File) (RIO env) ()+sourceSystemCompilers wanted = do+  searchPath <- view exeSearchPathL+  for_ names $ \name -> for_ searchPath $ \dir -> do+    fp <- resolveFile' $ addExe $ dir FP.</> name+    exists <- doesFileExist fp+    when exists $ yield fp+  where+    names =+      case wanted of+        WCGhc version ->+          [ "ghc-" ++ versionString version+          , "ghc"+          ]+        WCGhcjs{} -> ["ghcjs"]+        WCGhcGit{} -> [] -- only use sandboxed versions+    addExe+      | osIsWindows = (++ ".exe")+      | otherwise = id++-- | Download the most recent SetupInfo+getSetupInfo :: HasConfig env => String -> RIO env SetupInfo+getSetupInfo stackSetupYaml = do+    config <- view configL+    setupInfos <-+        mapM+            loadSetupInfo+            (SetupInfoFileOrURL stackSetupYaml :+             configSetupInfoLocations config)+    return (mconcat setupInfos)+  where+    loadSetupInfo (SetupInfoInline si) = return si+    loadSetupInfo (SetupInfoFileOrURL urlOrFile) = do+        bs <-+            case parseUrlThrow urlOrFile of+                Just req -> liftM (LBS.toStrict . getResponseBody) $ httpLbs req+                Nothing -> liftIO $ S.readFile urlOrFile+        WithJSONWarnings si warnings <- either throwM return (Yaml.decodeEither' bs)+        when (urlOrFile /= defaultSetupInfoYaml) $+            logJSONWarnings urlOrFile warnings+        return si++getInstalledTool :: [Tool]            -- ^ already installed+                 -> PackageName       -- ^ package to find+                 -> (Version -> Bool) -- ^ which versions are acceptable+                 -> Maybe Tool+getInstalledTool installed name goodVersion =+    if null available+        then Nothing+        else Just $ Tool $ maximumBy (comparing pkgVersion) available+  where+    available = mapMaybe goodPackage installed+    goodPackage (Tool pi') =+        if pkgName pi' == name &&+           goodVersion (pkgVersion pi')+            then Just pi'+            else Nothing+    goodPackage _ = Nothing++downloadAndInstallTool :: HasTerm env+                       => Path Abs Dir+                       -> DownloadInfo+                       -> Tool+                       -> (Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ())+                       -> RIO env Tool+downloadAndInstallTool programsDir downloadInfo tool installer = do+    ensureDir programsDir+    (file, at) <- downloadFromInfo programsDir downloadInfo tool+    dir <- installDir programsDir tool+    tempDir <- tempInstallDir programsDir tool+    liftIO $ ignoringAbsence (removeDirRecur tempDir)+    ensureDir tempDir+    unmarkInstalled programsDir tool+    installer file at tempDir dir+    markInstalled programsDir tool+    liftIO $ ignoringAbsence (removeDirRecur tempDir)+    return tool++downloadAndInstallCompiler :: (HasConfig env, HasGHCVariant env)+                           => CompilerBuild+                           -> SetupInfo+                           -> WantedCompiler+                           -> VersionCheck+                           -> Maybe String+                           -> RIO env Tool+downloadAndInstallCompiler ghcBuild si wanted@WCGhc{} versionCheck mbindistURL = do+    ghcVariant <- view ghcVariantL+    (selectedVersion, downloadInfo) <- case mbindistURL of+        Just bindistURL -> do+            case ghcVariant of+                GHCCustom _ -> return ()+                _ -> throwM RequireCustomGHCVariant+            case wanted of+                WCGhc version ->+                    return (version, GHCDownloadInfo mempty mempty DownloadInfo+                             { downloadInfoUrl = T.pack bindistURL+                             , downloadInfoContentLength = Nothing+                             , downloadInfoSha1 = Nothing+                             , downloadInfoSha256 = Nothing+                             })+                _ ->+                    throwM WantedMustBeGHC+        _ -> do+            ghcKey <- getGhcKey ghcBuild+            case Map.lookup ghcKey $ siGHCs si of+                Nothing -> throwM $ UnknownOSKey ghcKey+                Just pairs_ -> getWantedCompilerInfo ghcKey versionCheck wanted ACGhc pairs_+    config <- view configL+    let installer =+            case configPlatform config of+                Platform _ Cabal.Windows -> installGHCWindows (Just selectedVersion)+                _ -> installGHCPosix (Just selectedVersion) downloadInfo+    logInfo $+        "Preparing to install GHC" <>+        (case ghcVariant of+            GHCStandard -> ""+            v -> " (" <> fromString (ghcVariantName v) <> ")") <>+        (case ghcBuild of+            CompilerBuildStandard -> ""+            b -> " (" <> fromString (compilerBuildName b) <> ")") <>+        " to an isolated location."+    logInfo "This will not interfere with any system-level installation."+    ghcPkgName <- parsePackageNameThrowing ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)+    let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion+    downloadAndInstallTool (configLocalPrograms config) (gdiDownloadInfo downloadInfo) tool (installer si)++downloadAndInstallCompiler _ _ WCGhcjs{} _ _ = throwIO NoLongerBuildGhcjs++downloadAndInstallCompiler _ _ WCGhcGit{} _ _ =+    error "downloadAndInstallCompiler: shouldn't be reached with ghc-git"++getWantedCompilerInfo :: (Ord k, MonadThrow m)+                      => Text+                      -> VersionCheck+                      -> WantedCompiler+                      -> (k -> ActualCompiler)+                      -> Map k a+                      -> m (k, a)+getWantedCompilerInfo key versionCheck wanted toCV pairs_ =+    case mpair of+        Just pair -> return pair+        Nothing -> throwM $ UnknownCompilerVersion (Set.singleton key) wanted (Set.fromList $ map toCV (Map.keys pairs_))+  where+    mpair =+        listToMaybe $+        sortBy (flip (comparing fst)) $+        filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs_)++-- | Download and install the first available compiler build.+downloadAndInstallPossibleCompilers+    :: (HasGHCVariant env, HasConfig env)+    => [CompilerBuild]+    -> SetupInfo+    -> WantedCompiler+    -> VersionCheck+    -> Maybe String+    -> RIO env (Tool, CompilerBuild)+downloadAndInstallPossibleCompilers possibleCompilers si wanted versionCheck mbindistURL =+    go possibleCompilers Nothing+  where+    -- This will stop as soon as one of the builds doesn't throw an @UnknownOSKey@ or+    -- @UnknownCompilerVersion@ exception (so it will only try subsequent builds if one is non-existent,+    -- not if the download or install fails for some other reason).+    -- The @Unknown*@ exceptions thrown by each attempt are combined into a single exception+    -- (if only @UnknownOSKey@ is thrown, then the first of those is rethrown, but if any+    -- @UnknownCompilerVersion@s are thrown then the attempted OS keys and available versions+    -- are unioned).+    go [] Nothing = throwM UnsupportedSetupConfiguration+    go [] (Just e) = throwM e+    go (b:bs) e = do+        logDebug $ "Trying to setup GHC build: " <> fromString (compilerBuildName b)+        er <- try $ downloadAndInstallCompiler b si wanted versionCheck mbindistURL+        case er of+            Left e'@(UnknownCompilerVersion ks' w' vs') ->+                case e of+                    Nothing -> go bs (Just e')+                    Just (UnknownOSKey k) ->+                        go bs $ Just $ UnknownCompilerVersion (Set.insert k ks') w' vs'+                    Just (UnknownCompilerVersion ks _ vs) ->+                        go bs $ Just $ UnknownCompilerVersion (Set.union ks' ks) w' (Set.union vs' vs)+                    Just x -> throwM x+            Left e'@(UnknownOSKey k') ->+                case e of+                    Nothing -> go bs (Just e')+                    Just (UnknownOSKey _) -> go bs e+                    Just (UnknownCompilerVersion ks w vs) ->+                        go bs $ Just $ UnknownCompilerVersion (Set.insert k' ks) w vs+                    Just x -> throwM x+            Left e' -> throwM e'+            Right r -> return (r, b)++getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)+          => CompilerBuild -> m Text+getGhcKey ghcBuild = do+    ghcVariant <- view ghcVariantL+    platform <- view platformL+    osKey <- getOSKey platform+    return $ osKey <> T.pack (ghcVariantSuffix ghcVariant) <> T.pack (compilerBuildSuffix ghcBuild)++getOSKey :: (MonadThrow m)+         => Platform -> m Text+getOSKey platform =+    case platform of+        Platform I386                  Cabal.Linux   -> return "linux32"+        Platform X86_64                Cabal.Linux   -> return "linux64"+        Platform I386                  Cabal.OSX     -> return "macosx"+        Platform X86_64                Cabal.OSX     -> return "macosx"+        Platform I386                  Cabal.FreeBSD -> return "freebsd32"+        Platform X86_64                Cabal.FreeBSD -> return "freebsd64"+        Platform I386                  Cabal.OpenBSD -> return "openbsd32"+        Platform X86_64                Cabal.OpenBSD -> return "openbsd64"+        Platform I386                  Cabal.Windows -> return "windows32"+        Platform X86_64                Cabal.Windows -> return "windows64"+        Platform Arm                   Cabal.Linux   -> return "linux-armv7"+        Platform AArch64               Cabal.Linux   -> return "linux-aarch64"+        Platform arch os -> throwM $ UnsupportedSetupCombo os arch++downloadFromInfo+    :: HasTerm env+    => Path Abs Dir -> DownloadInfo -> Tool -> RIO env (Path Abs File, ArchiveType)+downloadFromInfo programsDir downloadInfo tool = do+    at <-+        case extension of+            ".tar.xz" -> return TarXz+            ".tar.bz2" -> return TarBz2+            ".tar.gz" -> return TarGz+            ".7z.exe" -> return SevenZ+            _ -> throwString $ "Error: Unknown extension for url: " ++ url+    relativeFile <- parseRelFile $ toolString tool ++ extension+    path <- case url of+        (parseUrlThrow -> Just _) -> do+            let path = programsDir </> relativeFile+            ensureDir programsDir+            chattyDownload (T.pack (toolString tool)) downloadInfo path+            return path+        (parseAbsFile -> Just path) -> do+            let DownloadInfo{downloadInfoContentLength=contentLength, downloadInfoSha1=sha1,+                             downloadInfoSha256=sha256} =+                    downloadInfo+            when (isJust contentLength) $+                logWarn ("`content-length` in not checked \n" <>+                          "and should not be specified when `url` is a file path")+            when (isJust sha1) $+                logWarn ("`sha1` is not checked and \n" <>+                          "should not be specified when `url` is a file path")+            when (isJust sha256) $+                logWarn ("`sha256` is not checked and \n" <>+                          "should not be specified when `url` is a file path")+            return path+        _ ->+            throwString $ "Error: `url` must be either an HTTP URL or absolute file path: " ++ url+    return (path, at)+  where+    url = T.unpack $ downloadInfoUrl downloadInfo+    extension = loop url+      where+        loop fp+            | ext `elem` [".tar", ".bz2", ".xz", ".exe", ".7z", ".gz"] = loop fp' ++ ext+            | otherwise = ""+          where+            (fp', ext) = FP.splitExtension fp++data ArchiveType+    = TarBz2+    | TarXz+    | TarGz+    | SevenZ++installGHCPosix :: HasConfig env+                => Maybe Version+                -> GHCDownloadInfo+                -> SetupInfo+                -> Path Abs File+                -> ArchiveType+                -> Path Abs Dir+                -> Path Abs Dir+                -> RIO env ()+installGHCPosix mversion downloadInfo _ archiveFile archiveType tempDir destDir = do+    platform <- view platformL+    menv0 <- view processContextL+    menv <- mkProcessContext (removeHaskellEnvVars (view envVarsL menv0))+    logDebug $ "menv = " <> displayShow (view envVarsL menv)+    (zipTool', compOpt) <-+        case archiveType of+            TarXz -> return ("xz", 'J')+            TarBz2 -> return ("bzip2", 'j')+            TarGz -> return ("gzip", 'z')+            SevenZ -> throwString "Don't know how to deal with .7z files on non-Windows"+    -- Slight hack: OpenBSD's tar doesn't support xz.+    -- https://github.com/commercialhaskell/stack/issues/2283#issuecomment-237980986+    let tarDep =+          case (platform, archiveType) of+            (Platform _ Cabal.OpenBSD, TarXz) -> checkDependency "gtar"+            _ -> checkDependency "tar"+    (zipTool, makeTool, tarTool) <- checkDependencies $ (,,)+        <$> checkDependency zipTool'+        <*> (checkDependency "gmake" <|> checkDependency "make")+        <*> tarDep++    logDebug $ "ziptool: " <> fromString zipTool+    logDebug $ "make: " <> fromString makeTool+    logDebug $ "tar: " <> fromString tarTool++    let runStep step wd env cmd args = do+          menv' <- modifyEnvVars menv (Map.union env)+          let logLines lvl = CB.lines .| CL.mapM_ (lvl . displayBytesUtf8)+              logStdout = logLines logDebug+              logStderr = logLines logError+          void $ withWorkingDir (toFilePath wd) $+                withProcessContext menv' $+                sinkProcessStderrStdout cmd args logStderr logStdout+                `catchAny` \ex -> do+                  logError $ displayShow ex+                  prettyError $ hang 2 (+                      "Error encountered while" <+> step <+> "GHC with"+                      <> line <>+                      style Shell (fromString (unwords (cmd : args)))+                      <> line <>+                      -- TODO: Figure out how to insert \ in the appropriate spots+                      -- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>+                      "run in " <> pretty wd+                      )+                    <> line <> line <>+                    "The following directories may now contain files, but won't be used by stack:"+                    <> line <>+                    "  -" <+> pretty tempDir+                    <> line <>+                    "  -" <+> pretty destDir+                    <> line <> line <>+                    "For more information consider rerunning with --verbose flag"+                    <> line+                  exitFailure++    logSticky $+      "Unpacking GHC into " <>+      fromString (toFilePath tempDir) <>+      " ..."+    logDebug $ "Unpacking " <> fromString (toFilePath archiveFile)+    runStep "unpacking" tempDir mempty tarTool [compOpt : "xf", toFilePath archiveFile]++    dir <- case mversion of+            Just version -> do+               relDir <- parseRelDir $ "ghc-" ++ versionString version+               return (tempDir </> relDir)+            Nothing      -> expectSingleUnpackedDir archiveFile tempDir++    logSticky "Configuring GHC ..."+    runStep "configuring" dir+        (gdiConfigureEnv downloadInfo)+        (toFilePath $ dir </> relFileConfigure)+        (("--prefix=" ++ toFilePath destDir) : map T.unpack (gdiConfigureOpts downloadInfo))++    logSticky "Installing GHC ..."+    runStep "installing" dir mempty makeTool ["install"]++    logStickyDone $ "Installed GHC."+    logDebug $ "GHC installed to " <> fromString (toFilePath destDir)++-- | Check if given processes appear to be present, throwing an exception if+-- missing.+checkDependencies :: CheckDependency env a -> RIO env a+checkDependencies (CheckDependency f) = f >>= either (throwIO . MissingDependencies) return++checkDependency :: HasProcessContext env => String -> CheckDependency env String+checkDependency tool = CheckDependency $ do+    exists <- doesExecutableExist tool+    return $ if exists then Right tool else Left [tool]++newtype CheckDependency env a = CheckDependency (RIO env (Either [String] a))+    deriving Functor+instance Applicative (CheckDependency env) where+    pure x = CheckDependency $ return (Right x)+    CheckDependency f <*> CheckDependency x = CheckDependency $ do+        f' <- f+        x' <- x+        return $+            case (f', x') of+                (Left e1, Left e2) -> Left $ e1 ++ e2+                (Left e, Right _) -> Left e+                (Right _, Left e) -> Left e+                (Right f'', Right x'') -> Right $ f'' x''+instance Alternative (CheckDependency env) where+    empty = CheckDependency $ return $ Left []+    CheckDependency x <|> CheckDependency y = CheckDependency $ do+        res1 <- x+        case res1 of+            Left _ -> y+            Right x' -> return $ Right x'++installGHCWindows :: HasConfig env+                  => Maybe Version+                  -> SetupInfo+                  -> Path Abs File+                  -> ArchiveType+                  -> Path Abs Dir+                  -> Path Abs Dir+                  -> RIO env ()+installGHCWindows mversion si archiveFile archiveType _tempDir destDir = do+    tarComponent <- mapM (\v -> parseRelDir $ "ghc-" ++ versionString v) mversion+    withUnpackedTarball7z "GHC" si archiveFile archiveType tarComponent destDir+    logInfo $ "GHC installed to " <> fromString (toFilePath destDir)++installMsys2Windows :: HasConfig env+                  => Text -- ^ OS Key+                  -> SetupInfo+                  -> Path Abs File+                  -> ArchiveType+                  -> Path Abs Dir+                  -> Path Abs Dir+                  -> RIO env ()+installMsys2Windows osKey si archiveFile archiveType _tempDir destDir = do+    exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir+    when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do+        logError $+            "Could not delete existing msys directory: " <>+            fromString (toFilePath destDir)+        throwM e++    msys <- parseRelDir $ "msys" ++ T.unpack (fromMaybe "32" $ T.stripPrefix "windows" osKey)+    withUnpackedTarball7z "MSYS2" si archiveFile archiveType (Just msys) destDir+++    -- I couldn't find this officially documented anywhere, but you need to run+    -- the MSYS shell once in order to initialize some pacman stuff. Once that+    -- run happens, you can just run commands as usual.+    menv0 <- view processContextL+    newEnv0 <- modifyEnvVars menv0 $ Map.insert "MSYSTEM" "MSYS"+    newEnv <- either throwM return $ augmentPathMap+                  [toFilePath $ destDir </> relDirUsr </> relDirBin]+                  (view envVarsL newEnv0)+    menv <- mkProcessContext newEnv+    withWorkingDir (toFilePath destDir) $ withProcessContext menv+      $ proc "sh" ["--login", "-c", "true"] runProcess_++    -- No longer installing git, it's unreliable+    -- (https://github.com/commercialhaskell/stack/issues/1046) and the+    -- MSYS2-installed version has bad CRLF defaults.+    --+    -- Install git. We could install other useful things in the future too.+    -- runCmd (Cmd (Just destDir) "pacman" menv ["-Sy", "--noconfirm", "git"]) Nothing++-- | Unpack a compressed tarball using 7zip.  Expects a single directory in+-- the unpacked results, which is renamed to the destination directory.+withUnpackedTarball7z :: HasConfig env+                      => String -- ^ Name of tool, used in error messages+                      -> SetupInfo+                      -> Path Abs File -- ^ Path to archive file+                      -> ArchiveType+                      -> Maybe (Path Rel Dir) -- ^ Name of directory expected in archive.  If Nothing, expects a single folder.+                      -> Path Abs Dir -- ^ Destination directory.+                      -> RIO env ()+withUnpackedTarball7z name si archiveFile archiveType msrcDir destDir = do+    suffix <-+        case archiveType of+            TarXz -> return ".xz"+            TarBz2 -> return ".bz2"+            TarGz -> return ".gz"+            _ -> throwString $ name ++ " must be a tarball file"+    tarFile <-+        case T.stripSuffix suffix $ T.pack $ toFilePath (filename archiveFile) of+            Nothing -> throwString $ "Invalid " ++ name ++ " filename: " ++ show archiveFile+            Just x -> parseRelFile $ T.unpack x+    run7z <- setup7z si+    let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp"+    ensureDir (parent destDir)+    withRunInIO $ \run -> withTempDir (parent destDir) tmpName $ \tmpDir -> run $ do+        liftIO $ ignoringAbsence (removeDirRecur destDir)+        run7z tmpDir archiveFile+        run7z tmpDir (tmpDir </> tarFile)+        absSrcDir <- case msrcDir of+            Just srcDir -> return $ tmpDir </> srcDir+            Nothing -> expectSingleUnpackedDir archiveFile tmpDir+        renameDir absSrcDir destDir++expectSingleUnpackedDir :: (MonadIO m, MonadThrow m) => Path Abs File -> Path Abs Dir -> m (Path Abs Dir)+expectSingleUnpackedDir archiveFile destDir = do+    contents <- listDir destDir+    case contents of+        ([dir], _ ) -> return dir+        _ -> throwString $ "Expected a single directory within unpacked " ++ toFilePath archiveFile++-- | Download 7z as necessary, and get a function for unpacking things.+--+-- Returned function takes an unpack directory and archive.+setup7z :: (HasConfig env, MonadIO m)+        => SetupInfo+        -> RIO env (Path Abs Dir -> Path Abs File -> m ())+setup7z si = do+    dir <- view $ configL.to configLocalPrograms+    ensureDir dir+    let exe = dir </> relFile7zexe+        dll = dir </> relFile7zdll+    case (siSevenzDll si, siSevenzExe si) of+        (Just sevenzDll, Just sevenzExe) -> do+            chattyDownload "7z.dll" sevenzDll dll+            chattyDownload "7z.exe" sevenzExe exe+            withRunInIO $ \run -> return $ \outdir archive -> liftIO $ run $ do+                let cmd = toFilePath exe+                    args =+                        [ "x"+                        , "-o" ++ toFilePath outdir+                        , "-y"+                        , toFilePath archive+                        ]+                let archiveDisplay = fromString $ FP.takeFileName $ toFilePath archive+                    isExtract = FP.takeExtension (toFilePath archive) == ".tar"+                logInfo $+                  (if isExtract then "Extracting " else "Decompressing ") <>+                  archiveDisplay <> "..."+                ec <-+                  proc cmd args $ \pc ->+                  if isExtract+                    then withProcess (setStdout createSource pc) $ \p -> do+                        total <- runConduit+                            $ getStdout p+                           .| filterCE (== 10) -- newline characters+                           .| foldMC+                                (\count bs -> do+                                    let count' = count + S.length bs+                                    logSticky $ "Extracted " <> RIO.display count' <> " files"+                                    pure count'+                                )+                                0+                        logStickyDone $+                          "Extracted total of " <>+                          RIO.display total <>+                          " files from " <>+                          archiveDisplay+                        waitExitCode p+                    else runProcess pc+                when (ec /= ExitSuccess)+                    $ liftIO $ throwM (ProblemWhileDecompressing archive)+        _ -> throwM SetupInfoMissingSevenz++chattyDownload :: HasTerm env+               => Text          -- ^ label+               -> DownloadInfo  -- ^ URL, content-length, sha1, and sha256+               -> Path Abs File -- ^ destination+               -> RIO env ()+chattyDownload label downloadInfo path = do+    let url = downloadInfoUrl downloadInfo+    req <- parseUrlThrow $ T.unpack url+    logSticky $+      "Preparing to download " <>+      RIO.display label <>+      " ..."+    logDebug $+      "Downloading from " <>+      RIO.display url <>+      " to " <>+      fromString (toFilePath path) <>+      " ..."+    hashChecks <- fmap catMaybes $ forM+      [ ("sha1",   HashCheck SHA1,   downloadInfoSha1)+      , ("sha256", HashCheck SHA256, downloadInfoSha256)+      ]+      $ \(name, constr, getter) ->+        case getter downloadInfo of+          Just bs -> do+            logDebug $+                "Will check against " <>+                name <>+                " hash: " <>+                displayBytesUtf8 bs+            return $ Just $ constr $ CheckHexDigestByteString bs+          Nothing -> return Nothing+    when (null hashChecks) $ logWarn $+        "No sha1 or sha256 found in metadata," <>+        " download hash won't be checked."+    let dReq = DownloadRequest+            { drRequest = req+            , drHashChecks = hashChecks+            , drLengthCheck = mtotalSize+            , drRetryPolicy = drRetryPolicyDefault+            }+    x <- verifiedDownload dReq path chattyDownloadProgress+    if x+        then logStickyDone ("Downloaded " <> RIO.display label <> ".")+        else logStickyDone "Already downloaded."+  where+    mtotalSize = downloadInfoContentLength downloadInfo+    chattyDownloadProgress _ = do+        _ <- logSticky $ RIO.display label <> ": download has begun"+        CL.map (Sum . S.length)+          .| chunksOverTime 1+          .| go+      where+        go = evalStateC 0 $ awaitForever $ \(Sum size) -> do+            modify (+ size)+            totalSoFar <- get+            logSticky $ fromString $+                case mtotalSize of+                    Nothing -> chattyProgressNoTotal totalSoFar+                    Just 0 -> chattyProgressNoTotal totalSoFar+                    Just totalSize -> chattyProgressWithTotal totalSoFar totalSize++        -- Example: ghc: 42.13 KiB downloaded...+        chattyProgressNoTotal totalSoFar =+            printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...")+                   (T.unpack label)++        -- Example: ghc: 50.00 MiB / 100.00 MiB (50.00%) downloaded...+        chattyProgressWithTotal totalSoFar total =+          printf ("%s: " <>+                  bytesfmt "%7.2f" totalSoFar <> " / " <>+                  bytesfmt "%.2f" total <>+                  " (%6.2f%%) downloaded...")+                 (T.unpack label)+                 percentage+          where percentage :: Double+                percentage = fromIntegral totalSoFar / fromIntegral total * 100++-- | Given a printf format string for the decimal part and a number of+-- bytes, formats the bytes using an appropiate unit and returns the+-- formatted string.+--+-- >>> bytesfmt "%.2" 512368+-- "500.359375 KiB"+bytesfmt :: Integral a => String -> a -> String+bytesfmt formatter bs = printf (formatter <> " %s")+                               (fromIntegral (signum bs) * dec :: Double)+                               (bytesSuffixes !! i)+  where+    (dec,i) = getSuffix (abs bs)+    getSuffix n = until p (\(x,y) -> (x / 1024, y+1)) (fromIntegral n,0)+      where p (n',numDivs) = n' < 1024 || numDivs == (length bytesSuffixes - 1)+    bytesSuffixes :: [String]+    bytesSuffixes = ["B","KiB","MiB","GiB","TiB","PiB","EiB","ZiB","YiB"]++-- Await eagerly (collect with monoidal append),+-- but space out yields by at least the given amount of time.+-- The final yield may come sooner, and may be a superfluous mempty.+-- Note that Integer and Float literals can be turned into NominalDiffTime+-- (these literals are interpreted as "seconds")+chunksOverTime :: (Monoid a, Semigroup a, MonadIO m) => NominalDiffTime -> ConduitM a a m ()+chunksOverTime diff = do+    currentTime <- liftIO getCurrentTime+    evalStateC (currentTime, mempty) go+  where+    -- State is a tuple of:+    -- * the last time a yield happened (or the beginning of the sink)+    -- * the accumulated awaits since the last yield+    go = await >>= \case+      Nothing -> do+        (_, acc) <- get+        yield acc+      Just a -> do+        (lastTime, acc) <- get+        let acc' = acc <> a+        currentTime <- liftIO getCurrentTime+        if diff < diffUTCTime currentTime lastTime+          then put (currentTime, mempty) >> yield acc'+          else put (lastTime,    acc')+        go++-- | Perform a basic sanity check of GHC+sanityCheck :: (HasProcessContext env, HasLogFunc env)+            => Path Abs File -> RIO env ()+sanityCheck ghc = withSystemTempDir "stack-sanity-check" $ \dir -> do+    let fp = toFilePath $ dir </> relFileMainHs+    liftIO $ S.writeFile fp $ T.encodeUtf8 $ T.pack $ unlines+        [ "import Distribution.Simple" -- ensure Cabal library is present+        , "main = putStrLn \"Hello World\""+        ]+    logDebug $ "Performing a sanity check on: " <> fromString (toFilePath ghc)+    eres <- withWorkingDir (toFilePath dir) $ proc (toFilePath ghc)+        [ fp+        , "-no-user-package-db"+        ] $ try . readProcess_+    case eres of+        Left e -> throwIO $ GHCSanityCheckCompileFailed e ghc+        Right _ -> return () -- TODO check that the output of running the command is correct++-- Remove potentially confusing environment variables+removeHaskellEnvVars :: Map Text Text -> Map Text Text+removeHaskellEnvVars =+    Map.delete "GHCJS_PACKAGE_PATH" .+    Map.delete "GHC_PACKAGE_PATH" .+    Map.delete "GHC_ENVIRONMENT" .+    Map.delete "HASKELL_PACKAGE_SANDBOX" .+    Map.delete "HASKELL_PACKAGE_SANDBOXES" .+    Map.delete "HASKELL_DIST_DIR" .+    -- https://github.com/commercialhaskell/stack/issues/1460+    Map.delete "DESTDIR" .+    -- https://github.com/commercialhaskell/stack/issues/3444+    Map.delete "GHCRTS"++-- | Get map of environment variables to set to change the GHC's encoding to UTF-8+getUtf8EnvVars+    :: (HasProcessContext env, HasPlatform env, HasLogFunc env)+    => ActualCompiler+    -> RIO env (Map Text Text)+getUtf8EnvVars compilerVer =+    if getGhcVersion compilerVer >= mkVersion [7, 10, 3]+        -- GHC_CHARENC supported by GHC >=7.10.3+        then return $ Map.singleton "GHC_CHARENC" "UTF-8"+        else legacyLocale+  where+    legacyLocale = do+        menv <- view processContextL+        Platform _ os <- view platformL+        if os == Cabal.Windows+            then+                 -- On Windows, locale is controlled by the code page, so we don't set any environment+                 -- variables.+                 return+                     Map.empty+            else do+                let checkedVars = map checkVar (Map.toList $ view envVarsL menv)+                    -- List of environment variables that will need to be updated to set UTF-8 (because+                    -- they currently do not specify UTF-8).+                    needChangeVars = concatMap fst checkedVars+                    -- Set of locale-related environment variables that have already have a value.+                    existingVarNames = Set.unions (map snd checkedVars)+                    -- True if a locale is already specified by one of the "global" locale variables.+                    hasAnyExisting =+                        any (`Set.member` existingVarNames) ["LANG", "LANGUAGE", "LC_ALL"]+                if null needChangeVars && hasAnyExisting+                    then+                         -- If no variables need changes and at least one "global" variable is set, no+                         -- changes to environment need to be made.+                         return+                             Map.empty+                    else do+                        -- Get a list of known locales by running @locale -a@.+                        elocales <- tryAny $ fmap fst $ proc "locale" ["-a"] readProcess_+                        let+                            -- Filter the list to only include locales with UTF-8 encoding.+                            utf8Locales =+                                case elocales of+                                    Left _ -> []+                                    Right locales ->+                                        filter+                                            isUtf8Locale+                                            (T.lines $+                                             T.decodeUtf8With+                                                 T.lenientDecode $+                                                 LBS.toStrict locales)+                            mfallback = getFallbackLocale utf8Locales+                        when+                            (isNothing mfallback)+                            (logWarn+                                 "Warning: unable to set locale to UTF-8 encoding; GHC may fail with 'invalid character'")+                        let+                            -- Get the new values of variables to adjust.+                            changes =+                                Map.unions $+                                map+                                    (adjustedVarValue menv utf8Locales mfallback)+                                    needChangeVars+                            -- Get the values of variables to add.+                            adds+                              | hasAnyExisting =+                                  -- If we already have a "global" variable, then nothing needs+                                  -- to be added.+                                  Map.empty+                              | otherwise =+                                  -- If we don't already have a "global" variable, then set LANG to the+                                  -- fallback.+                                  case mfallback of+                                      Nothing -> Map.empty+                                      Just fallback ->+                                          Map.singleton "LANG" fallback+                        return (Map.union changes adds)+    -- Determines whether an environment variable is locale-related and, if so, whether it needs to+    -- be adjusted.+    checkVar+        :: (Text, Text) -> ([Text], Set Text)+    checkVar (k,v) =+        if k `elem` ["LANG", "LANGUAGE"] || "LC_" `T.isPrefixOf` k+            then if isUtf8Locale v+                     then ([], Set.singleton k)+                     else ([k], Set.singleton k)+            else ([], Set.empty)+    -- Adjusted value of an existing locale variable.  Looks for valid UTF-8 encodings with+    -- same language /and/ territory, then with same language, and finally the first UTF-8 locale+    -- returned by @locale -a@.+    adjustedVarValue+        :: ProcessContext -> [Text] -> Maybe Text -> Text -> Map Text Text+    adjustedVarValue menv utf8Locales mfallback k =+        case Map.lookup k (view envVarsL menv) of+            Nothing -> Map.empty+            Just v ->+                case concatMap+                         (matchingLocales utf8Locales)+                         [ T.takeWhile (/= '.') v <> "."+                         , T.takeWhile (/= '_') v <> "_"] of+                    (v':_) -> Map.singleton k v'+                    [] ->+                        case mfallback of+                            Just fallback -> Map.singleton k fallback+                            Nothing -> Map.empty+    -- Determine the fallback locale, by looking for any UTF-8 locale prefixed with the list in+    -- @fallbackPrefixes@, and if not found, picking the first UTF-8 encoding returned by @locale+    -- -a@.+    getFallbackLocale+        :: [Text] -> Maybe Text+    getFallbackLocale utf8Locales =+        case concatMap (matchingLocales utf8Locales) fallbackPrefixes of+            (v:_) -> Just v+            [] ->+                case utf8Locales of+                    [] -> Nothing+                    (v:_) -> Just v+    -- Filter the list of locales for any with the given prefixes (case-insitive).+    matchingLocales+        :: [Text] -> Text -> [Text]+    matchingLocales utf8Locales prefix =+        filter (\v -> T.toLower prefix `T.isPrefixOf` T.toLower v) utf8Locales+    -- Does the locale have one of the encodings in @utf8Suffixes@ (case-insensitive)?+    isUtf8Locale locale =+      any (\ v -> T.toLower v `T.isSuffixOf` T.toLower locale) utf8Suffixes+    -- Prefixes of fallback locales (case-insensitive)+    fallbackPrefixes = ["C.", "en_US.", "en_"]+    -- Suffixes of UTF-8 locales (case-insensitive)+    utf8Suffixes = [".UTF-8", ".utf8"]++-- Binary Stack upgrades++newtype StackReleaseInfo = StackReleaseInfo Value++downloadStackReleaseInfo :: (MonadIO m, MonadThrow 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 throwString $ "Could not get release information for Stack from: " ++ url++preferredPlatforms :: (MonadReader env m, HasPlatform env, MonadThrow m)+                   => m [(Bool, String)]+preferredPlatforms = do+    Platform arch' os' <- view platformL+    (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")+        _ -> throwM $ stringException $ "Binary upgrade not yet supported on OS: " ++ show os'+    arch <-+      case arch' of+        I386 -> return "i386"+        X86_64 -> return "x86_64"+        Arm -> return "arm"+        _ -> throwM $ stringException $ "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+    :: HasConfig env+    => [(Bool, String)] -- ^ acceptable platforms+    -> StackReleaseInfo+    -> Path Abs Dir -- ^ destination directory+    -> Bool -- ^ perform PATH-aware checking, see #3232+    -> (Path Abs File -> IO ()) -- ^ test the temp exe before renaming+    -> RIO env ()+downloadStackExe platforms0 archiveInfo destDir checkPath testExe = do+    (isWindows, archiveURL) <-+      let loop [] = throwString $ "Unable to find binary Stack archive for platforms: "+                                ++ unwords (map snd platforms0)+          loop ((isWindows, p'):ps) = do+            let p = T.pack p'+            logInfo $ "Querying for archive location for platform: " <> fromString p'+            case findArchive archiveInfo p of+              Just x -> return (isWindows, x)+              Nothing -> loop ps+       in loop platforms0++    let (destFile, tmpFile)+            | isWindows =+                ( destDir </> relFileStackDotExe+                , destDir </> relFileStackDotTmpDotExe+                )+            | otherwise =+                ( destDir </> relFileStack+                , destDir </> relFileStackDotTmp+                )++    logInfo $ "Downloading from: " <> RIO.display 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 <- view platformL++    -- We need to call getExecutablePath before we overwrite the+    -- currently running binary: after that, Linux will append+    -- (deleted) to the filename.+    currExe <- liftIO getExecutablePath++    liftIO $ do+      setFileExecutable (toFilePath tmpFile)++      testExe tmpFile++      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++    destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir+    warnInstallSearchPathIssues destDir' ["stack"]++    logInfo $ "New stack executable available at " <> fromString (toFilePath destFile)++    when checkPath $ performPathChecking destFile currExe+      `catchAny` (logError . displayShow)+  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++-- | Ensure that the Stack executable download is in the same location+-- as the currently running executable. See:+-- https://github.com/commercialhaskell/stack/issues/3232+performPathChecking+    :: HasConfig env+    => Path Abs File -- ^ location of the newly downloaded file+    -> String -- ^ currently running executable+    -> RIO env ()+performPathChecking newFile executablePath = do+  executablePath' <- parseAbsFile executablePath+  unless (toFilePath newFile == executablePath) $ do+    logInfo $ "Also copying stack executable to " <> fromString executablePath+    tmpFile <- parseAbsFile $ executablePath ++ ".tmp"+    eres <- tryIO $ do+      liftIO $ copyFile newFile tmpFile+      setFileExecutable (toFilePath tmpFile)+      liftIO $ renameFile tmpFile executablePath'+      logInfo "Stack executable copied successfully!"+    case eres of+      Right () -> return ()+      Left e+        | isPermissionError e -> do+            logWarn $ "Permission error when trying to copy: " <> displayShow e+            logWarn "Should I try to perform the file copy using sudo? This may fail"+            toSudo <- promptBool "Try using sudo? (y/n) "+            when toSudo $ do+              let run cmd args = do+                    ec <- proc cmd args runProcess+                    when (ec /= ExitSuccess) $ error $ concat+                          [ "Process exited with "+                          , show ec+                          , ": "+                          , unwords (cmd:args)+                          ]+                  commands =+                    [ ("sudo",+                        [ "cp"+                        , toFilePath newFile+                        , toFilePath tmpFile+                        ])+                    , ("sudo",+                        [ "mv"+                        , toFilePath tmpFile+                        , executablePath+                        ])+                    ]+              logInfo "Going to run the following commands:"+              logInfo ""+              forM_ commands $ \(cmd, args) ->+                logInfo $ "-  " <> mconcat (intersperse " " (fromString <$> (cmd:args)))+              mapM_ (uncurry run) commands+              logInfo ""+              logInfo "sudo file copy worked!"+        | otherwise -> throwM e++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.unpack (T.drop 1 rawName)
src/Stack/Setup/Installed.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} @@ -17,14 +15,12 @@     , toolString     , toolNameString     , parseToolText-    , ExtraDirs (..)     , extraDirs     , installDir     , tempInstallDir     ) where  import           Stack.Prelude-import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as BL import           Data.List hiding (concat, elem, maximumBy)@@ -32,31 +28,30 @@ import qualified Data.Text.Encoding as T import           Distribution.System (Platform (..)) import qualified Distribution.System as Cabal-import           Generics.Deriving.Monoid (mappenddefault, memptydefault) import           Path import           Path.IO+import           Stack.Constants import           Stack.Types.Compiler import           Stack.Types.Config-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Version import           RIO.Process  data Tool     = Tool PackageIdentifier -- ^ e.g. ghc-7.8.4, msys2-20150512-    | ToolGhcjs (CompilerVersion 'CVActual) -- ^ e.g. ghcjs-0.1.0_ghc-7.10.2+    | ToolGhcGit !Text !Text   -- ^ e.g. ghc-git-COMMIT_ID-FLAVOUR+    deriving (Eq)  toolString :: Tool -> String toolString (Tool ident) = packageIdentifierString ident-toolString (ToolGhcjs cv) = compilerVersionString cv+toolString (ToolGhcGit commit flavour) = "ghc-git-" ++ T.unpack commit ++ "-" ++ T.unpack flavour  toolNameString :: Tool -> String-toolNameString (Tool ident) = packageNameString $ packageIdentifierName ident-toolNameString ToolGhcjs{} = "ghcjs"+toolNameString (Tool ident) = packageNameString $ pkgName ident+toolNameString ToolGhcGit{} = "ghc-git"  parseToolText :: Text -> Maybe Tool-parseToolText (parseCompilerVersion -> Just cv@GhcjsVersion{}) = Just (ToolGhcjs cv)-parseToolText (parsePackageIdentifierFromString . T.unpack -> Just pkgId) = Just (Tool pkgId)+parseToolText (parseWantedCompiler -> Right WCGhcjs{}) = Nothing+parseToolText (parseWantedCompiler -> Right (WCGhcGit c f)) = Just (ToolGhcGit c f)+parseToolText (parsePackageIdentifier . T.unpack -> Just pkgId) = Just (Tool pkgId) parseToolText _ = Nothing  markInstalled :: (MonadIO m, MonadThrow m)@@ -65,7 +60,7 @@               -> m () markInstalled programsPath tool = do     fpRel <- parseRelFile $ toolString tool ++ ".installed"-    liftIO $ B.writeFile (toFilePath $ programsPath </> fpRel) "installed"+    writeBinaryFileAtomic (programsPath </> fpRel) "installed"  unmarkInstalled :: MonadIO m                 => Path Abs Dir@@ -101,14 +96,15 @@ getCompilerVersion   :: (HasProcessContext env, HasLogFunc env)   => WhichCompiler-  -> RIO env (CompilerVersion 'CVActual)-getCompilerVersion wc =+  -> Path Abs File -- ^ executable+  -> RIO env ActualCompiler+getCompilerVersion wc exe = do     case wc of         Ghc -> do             logDebug "Asking GHC for its version"-            bs <- fst <$> proc "ghc" ["--numeric-version"] readProcess_+            bs <- fst <$> proc (toFilePath exe) ["--numeric-version"] readProcess_             let (_, ghcVersion) = versionFromEnd $ BL.toStrict bs-            x <- GhcVersion <$> parseVersion (T.decodeUtf8 ghcVersion)+            x <- ACGhc <$> parseVersionThrowing (T.unpack $ T.decodeUtf8 ghcVersion)             logDebug $ "GHC version is: " <> display x             return x         Ghcjs -> do@@ -117,10 +113,10 @@             -- Output looks like             --             -- The Glorious Glasgow Haskell Compilation System for JavaScript, version 0.1.0 (GHC 7.10.2)-            bs <- fst <$> proc "ghcjs" ["--version"] readProcess_-            let (rest, ghcVersion) = T.decodeUtf8 <$> versionFromEnd (BL.toStrict bs)-                (_, ghcjsVersion) = T.decodeUtf8 <$> versionFromEnd rest-            GhcjsVersion <$> parseVersion ghcjsVersion <*> parseVersion ghcVersion+            bs <- fst <$> proc (toFilePath exe) ["--version"] readProcess_+            let (rest, ghcVersion) = T.unpack . T.decodeUtf8 <$> versionFromEnd (BL.toStrict bs)+                (_, ghcjsVersion) = T.unpack . T.decodeUtf8 <$> versionFromEnd rest+            ACGhcjs <$> parseVersionThrowing ghcjsVersion <*> parseVersionThrowing ghcVersion   where     versionFromEnd = S8.spanEnd isValid . fst . S8.breakEnd isValid     isValid c = c == '.' || ('0' <= c && c <= '9')@@ -133,46 +129,41 @@     case (configPlatform config, toolNameString tool) of         (Platform _ Cabal.Windows, isGHC -> True) -> return mempty             { edBins =-                [ dir </> $(mkRelDir "bin")-                , dir </> $(mkRelDir "mingw") </> $(mkRelDir "bin")+                [ dir </> relDirBin+                , dir </> relDirMingw </> relDirBin                 ]             }         (Platform Cabal.I386 Cabal.Windows, "msys2") -> return mempty             { edBins =-                [ dir </> $(mkRelDir "mingw32") </> $(mkRelDir "bin")-                , dir </> $(mkRelDir "usr") </> $(mkRelDir "bin")-                , dir </> $(mkRelDir "usr") </> $(mkRelDir "local") </> $(mkRelDir "bin")+                [ dir </> relDirMingw32 </> relDirBin+                , dir </> relDirUsr </> relDirBin+                , dir </> relDirUsr </> relDirLocal </> relDirBin                 ]             , edInclude =-                [ dir </> $(mkRelDir "mingw32") </> $(mkRelDir "include")+                [ dir </> relDirMingw32 </> relDirInclude                 ]             , edLib =-                [ dir </> $(mkRelDir "mingw32") </> $(mkRelDir "lib")-                , dir </> $(mkRelDir "mingw32") </> $(mkRelDir "bin")+                [ dir </> relDirMingw32 </> relDirLib+                , dir </> relDirMingw32 </> relDirBin                 ]             }         (Platform Cabal.X86_64 Cabal.Windows, "msys2") -> return mempty             { edBins =-                [ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "bin")-                , dir </> $(mkRelDir "usr") </> $(mkRelDir "bin")-                , dir </> $(mkRelDir "usr") </> $(mkRelDir "local") </> $(mkRelDir "bin")+                [ dir </> relDirMingw64 </> relDirBin+                , dir </> relDirUsr </> relDirBin+                , dir </> relDirUsr </> relDirLocal </> relDirBin                 ]             , edInclude =-                [ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "include")+                [ dir </> relDirMingw64 </> relDirInclude                 ]             , edLib =-                [ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "lib")-                , dir </> $(mkRelDir "mingw64") </> $(mkRelDir "bin")+                [ dir </> relDirMingw64 </> relDirLib+                , dir </> relDirMingw64 </> relDirBin                 ]             }         (_, isGHC -> True) -> return mempty             { edBins =-                [ dir </> $(mkRelDir "bin")-                ]-            }-        (_, isGHCJS -> True) -> return mempty-            { edBins =-                [ dir </> $(mkRelDir "bin")+                [ dir </> relDirBin                 ]             }         (Platform _ x, toolName) -> do@@ -180,18 +171,6 @@             return mempty   where     isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n-    isGHCJS n = "ghcjs" == n--data ExtraDirs = ExtraDirs-    { edBins :: ![Path Abs Dir]-    , edInclude :: ![Path Abs Dir]-    , edLib :: ![Path Abs Dir]-    } deriving (Show, Generic)-instance Semigroup ExtraDirs where-    (<>) = mappenddefault-instance Monoid ExtraDirs where-    mempty = memptydefault-    mappend = (<>)  installDir :: (MonadReader env m, MonadThrow m)            => Path Abs Dir
src/Stack/SetupCmd.hs view
@@ -13,7 +13,6 @@     ) where  import           Control.Applicative-import           Control.Monad.Logger () import           Control.Monad.Reader import qualified Data.Text as T import qualified Options.Applicative as OA@@ -22,14 +21,12 @@ import           Path import           Stack.Prelude import           Stack.Setup-import           Stack.Types.Compiler import           Stack.Types.Config import           Stack.Types.Version  data SetupCmdOpts = SetupCmdOpts-    { scoCompilerVersion :: !(Maybe (CompilerVersion 'CVWanted))+    { scoCompilerVersion :: !(Maybe WantedCompiler)     , scoForceReinstall  :: !Bool-    , scoUpgradeCabal    :: !(Maybe UpgradeTo)     , scoSetupInfoYaml   :: !String     , scoGHCBindistURL   :: !(Maybe String)     , scoGHCJSBootOpts   :: ![String]@@ -49,22 +46,6 @@             <> OA.metavar "URL"             <> OA.value defaultSetupInfoYaml ) -cabalUpgradeParser :: OA.Parser UpgradeTo-cabalUpgradeParser = Specific <$> version' <|> latestParser-    where-        versionReader = do-            s <- OA.readerAsk-            case parseVersion (T.pack s) of-                Nothing -> OA.readerError $ "Invalid version: " ++ s-                Just v  -> return v-        version' = OA.option versionReader (-            OA.long "install-cabal"-         <> OA.metavar "VERSION"-         <> OA.help "Install a specific version of Cabal" )-        latestParser = OA.flag' Latest (-            OA.long "upgrade-cabal"-         <> OA.help "DEPRECATED Install latest version of Cabal globally" )- setupParser :: OA.Parser SetupCmdOpts setupParser = SetupCmdOpts     <$> OA.optional (OA.argument readVersion@@ -75,7 +56,6 @@             "reinstall"             "reinstalling GHC, even if available (incompatible with --system-ghc)"             OA.idm-    <*> OA.optional cabalUpgradeParser     <*> setupYamlCompatParser     <*> OA.optional (OA.strOption             (OA.long "ghc-bindist"@@ -92,23 +72,23 @@   where     readVersion = do         s <- OA.readerAsk-        case parseCompilerVersion ("ghc-" <> T.pack s) of-            Nothing ->-                case parseCompilerVersion (T.pack s) of-                    Nothing -> OA.readerError $ "Invalid version: " ++ s-                    Just x -> return x-            Just x -> return x+        case parseWantedCompiler ("ghc-" <> T.pack s) of+            Left _ ->+                case parseWantedCompiler (T.pack s) of+                    Left _ -> OA.readerError $ "Invalid version: " ++ s+                    Right x -> return x+            Right x -> return x  setup     :: (HasConfig env, HasGHCVariant env)     => SetupCmdOpts-    -> CompilerVersion 'CVWanted+    -> WantedCompiler     -> VersionCheck     -> Maybe (Path Abs File)     -> RIO env () setup SetupCmdOpts{..} wantedCompiler compilerCheck mstack = do     Config{..} <- view configL-    (_, _, sandboxedGhc) <- ensureCompiler SetupOpts+    sandboxedGhc <- cpSandboxed . fst <$> ensureCompilerAndMsys SetupOpts         { soptsInstallIfMissing = True         , soptsUseSystem = configSystemGHC && not scoForceReinstall         , soptsWantedCompiler = wantedCompiler@@ -118,15 +98,15 @@         , soptsSanityCheck = True         , soptsSkipGhcCheck = False         , soptsSkipMsys = configSkipMsys-        , soptsUpgradeCabal = scoUpgradeCabal         , soptsResolveMissingGHC = Nothing         , soptsSetupInfoYaml = scoSetupInfoYaml         , soptsGHCBindistURL = scoGHCBindistURL         , soptsGHCJSBootOpts = scoGHCJSBootOpts ++ ["--clean" | scoGHCJSBootClean]         }     let compiler = case wantedCompiler of-            GhcVersion _ -> "GHC"-            GhcjsVersion {} -> "GHCJS"+            WCGhc _ -> "GHC"+            WCGhcGit{} -> "GHC (built from source)"+            WCGhcjs {} -> "GHCJS"     if sandboxedGhc         then logInfo $ "stack will use a sandboxed " <> compiler <> " it installed"         else logInfo $ "stack will use the " <> compiler <> " on your PATH"
− src/Stack/Sig.hs 
@@ -1,15 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-|-Module      : Stack.Sig-Description : GPG Signatures for Stack-Copyright   : (c) 2015-2018, Stack contributors-License     : BSD3-Maintainer  : Tim Dysinger <tim@fpcomplete.com>-Stability   : experimental-Portability : POSIX--}--module Stack.Sig (module Sig) where--import Stack.Sig.GPG as Sig-import Stack.Sig.Sign as Sig
− src/Stack/Sig/GPG.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}--{-|-Module      : Stack.Sig.GPG-Description : GPG Functions-Copyright   : (c) 2015-2018, Stack contributors-License     : BSD3-Maintainer  : Tim Dysinger <tim@fpcomplete.com>-Stability   : experimental-Portability : POSIX--}--module Stack.Sig.GPG (gpgSign, gpgVerify) where--import           Stack.Prelude-import qualified Data.ByteString.Char8 as C-import           Data.List (find, isPrefixOf)-import qualified Data.Text as T-import           Stack.Types.Sig-import           System.Directory (findExecutable)-import           System.Environment (lookupEnv)-import           System.Exit (ExitCode(..))-import           System.IO (hGetContents, hPutStrLn)-import           System.Info (os)-import           System.Process (ProcessHandle, runInteractiveProcess,-                                 waitForProcess)---- | Sign a file path with GPG, returning the @Signature@.-gpgSign-    :: HasLogFunc env-    => Path Abs File -> RIO env Signature-gpgSign path = do-    gpgWarnTTY-    (_hIn,hOut,hErr,process) <--        gpg-            [ "--output"-            , "-"-            , "--use-agent"-            , "--detach-sig"-            , "--armor"-            , toFilePath path]-    (out,err,code) <--        liftIO-            ((,,) <$>-             hGetContents hOut <*>-             hGetContents hErr <*>-             waitForProcess process)-    if code /= ExitSuccess-        then throwM (GPGSignException $ out <> "\n" <> err)-        else return (Signature $ C.pack out)---- | Verify the @Signature@ of a file path returning the--- @Fingerprint@.-gpgVerify-    :: (MonadIO m, MonadThrow m)-    => Signature -> Path Abs File -> m Fingerprint-gpgVerify (Signature signature) path = do-    (hIn,hOut,hErr,process) <--        gpg ["--verify", "--with-fingerprint", "-", toFilePath path]-    (_in,out,err,code) <--        liftIO-            ((,,,) <$>-             hPutStrLn hIn (C.unpack signature) <*>-             hGetContents hOut <*>-             hGetContents hErr <*>-             waitForProcess process)-    if code /= ExitSuccess-        then throwM (GPGVerifyException (out ++ "\n" ++ err))-        else maybe-                 (throwM-                      (GPGFingerprintException-                           ("unable to extract fingerprint from output\n: " <>-                            out)))-                 return-                 (mkFingerprint . T.pack . concat . drop 3 <$>-                  find-                      ((==) ["Primary", "key", "fingerprint:"] . take 3)-                      (map words (lines err)))---- | Try to execute `gpg2` but fallback to `gpg` (as a backup)-gpg-    :: (MonadIO m, MonadThrow m)-    => [String] -> m (Handle, Handle, Handle, ProcessHandle)-gpg args = do-    mGpg2Path <- liftIO (findExecutable "gpg2")-    case mGpg2Path of-        Just _ -> liftIO (runInteractiveProcess "gpg2" args Nothing Nothing)-        Nothing -> do-            mGpgPath <- liftIO (findExecutable "gpg")-            case mGpgPath of-                Just _ ->-                    liftIO (runInteractiveProcess "gpg" args Nothing Nothing)-                Nothing -> throwM GPGNotFoundException---- | `man gpg-agent` shows that you need GPG_TTY environment variable set to--- properly deal with interactions with gpg-agent. (Doesn't apply to Windows--- though)-gpgWarnTTY :: HasLogFunc env => RIO env ()-gpgWarnTTY =-    unless-        ("ming" `isPrefixOf` os)-        (do mTTY <- liftIO (lookupEnv "GPG_TTY")-            when-                (null mTTY)-                (logWarn-                     "Environment variable GPG_TTY is not set (see `man gpg-agent`)"))
− src/Stack/Sig/Sign.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}--{-|-Module      : Stack.Sig.Sign-Description : Signing Packages-Copyright   : (c) 2015-2018, Stack contributors-License     : BSD3-Maintainer  : Tim Dysinger <tim@fpcomplete.com>-Stability   : experimental-Portability : POSIX--}--module Stack.Sig.Sign (sign, signPackage, signTarBytes) where--import qualified Codec.Archive.Tar as Tar-import qualified Codec.Compression.GZip as GZip-import           Stack.Prelude-import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy as L-import           Network.HTTP.Download-import           Network.HTTP.StackClient (RequestBody (RequestBodyBS), setRequestMethod, setRequestBody, getResponseStatusCode, methodPut)-import           Path-import           Stack.Package-import           Stack.Sig.GPG-import           Stack.Types.PackageIdentifier-import           Stack.Types.Sig-import qualified System.FilePath as FP---- | Sign a haskell package with the given url of the signature--- service and a path to a tarball.-sign-    :: HasLogFunc env-    => String -> Path Abs File -> RIO env Signature-sign url filePath =-    withRunInIO $ \run ->-    withSystemTempDir-        "stack"-        (\tempDir ->-              do bytes <--                     liftIO-                         (fmap-                              GZip.decompress-                              (BS.readFile (toFilePath filePath)))-                 maybePath <- extractCabalFile tempDir (Tar.read bytes)-                 case maybePath of-                     Nothing -> throwM SigInvalidSDistTarBall-                     Just cabalPath -> do-                         pkg <- cabalFilePackageId (tempDir </> cabalPath)-                         run (signPackage url pkg filePath))-  where-    extractCabalFile tempDir (Tar.Next entry entries) =-        case Tar.entryContent entry of-            (Tar.NormalFile lbs _) ->-                case FP.splitFileName (Tar.entryPath entry) of-                    (folder,file)-                      | length (FP.splitDirectories folder) == 1 &&-                            FP.takeExtension file == ".cabal" -> do-                          cabalFile <- parseRelFile file-                          liftIO-                              (BS.writeFile-                                   (toFilePath (tempDir </> cabalFile))-                                   lbs)-                          return (Just cabalFile)-                    (_,_) -> extractCabalFile tempDir entries-            _ -> extractCabalFile tempDir entries-    extractCabalFile _ _ = return Nothing---- | Sign a haskell package with the given url to the signature--- service, a package tarball path (package tarball name) and a lazy--- bytestring of bytes that represent the tarball bytestream.  The--- function will write the bytes to the path in a temp dir and sign--- the tarball with GPG.-signTarBytes-    :: HasLogFunc env-    => String -> Path Rel File -> L.ByteString -> RIO env Signature-signTarBytes url tarPath bs =-    withSystemTempDir-        "stack"-        (\tempDir ->-              do let tempTarBall = tempDir </> tarPath-                 liftIO (L.writeFile (toFilePath tempTarBall) bs)-                 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-    :: HasLogFunc env-    => String -> PackageIdentifier -> Path Abs File -> RIO env Signature-signPackage url pkg filePath = do-    sig@(Signature signature) <- gpgSign filePath-    let (PackageIdentifier name version) = pkg-    fingerprint <- gpgVerify sig filePath-    let fullUrl =-            url <> "/upload/signature/" <> show name <> "/" <> show version <>-            "/" <>-            show fingerprint-    req <- parseUrlThrow fullUrl-    let put = setRequestMethod methodPut-            $ setRequestBody (RequestBodyBS signature) req-    res <- liftIO (httpLbs put)-    when-        (getResponseStatusCode res /= 200)-        (throwM (GPGSignException "unable to sign & upload package"))-    logInfo ("Signature uploaded to " <> fromString fullUrl)-    return sig
− src/Stack/Snapshot.hs 
@@ -1,822 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE EmptyDataDecls      #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE TupleSections       #-}-{-# LANGUAGE ViewPatterns        #-}---- | Reading in @SnapshotDef@s and converting them into--- @LoadedSnapshot@s.-module Stack.Snapshot-  ( loadResolver-  , loadSnapshot-  , calculatePackagePromotion-  ) where--import           Stack.Prelude hiding (Display (..))-import           Control.Monad.State.Strict      (get, put, StateT, execStateT)-import           Crypto.Hash.Conduit (hashFile)-import           Data.Aeson (withObject, (.!=), (.:), (.:?), Value (Object))-import           Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings, (..!=), (..:?), jsonSubWarningsT, withObjectWarnings, (..:))-import           Data.Aeson.Types (Parser, parseEither)-import           Data.Store.VersionTagged-import qualified Data.Conduit.List as CL-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Map as Map-import qualified Data.Set as Set-import           Data.Time (toGregorian)-import qualified Data.Text as T-import           Data.Text.Encoding (encodeUtf8)-import           Data.Yaml (decodeFileEither, ParseException (AesonException))-import           Distribution.InstalledPackageInfo (PError)-import           Distribution.PackageDescription (GenericPackageDescription)-import qualified Distribution.PackageDescription as C-import           Distribution.System (Platform)-import           Distribution.Text (display)-import qualified Distribution.Version as C-import           Network.HTTP.StackClient (Request)-import           Network.HTTP.Download-import qualified RIO-import           Network.URI (isURI)-import           Path-import           Path.IO-import           Stack.Constants-import           Stack.Package-import           Stack.PackageDump-import           Stack.PackageLocation-import           Stack.Types.BuildPlan-import           Stack.Types.FlagName-import           Stack.Types.GhcPkgId-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Version-import           Stack.Types.VersionIntervals-import           Stack.Types.Config-import           Stack.Types.Urls-import           Stack.Types.Compiler-import           Stack.Types.Resolver-import qualified System.Directory as Dir-import qualified System.FilePath as FilePath--type SinglePackageLocation = PackageLocationIndex FilePath--data SnapshotException-  = InvalidCabalFileInSnapshot !SinglePackageLocation !PError-  | PackageDefinedTwice !PackageName !SinglePackageLocation !SinglePackageLocation-  | UnmetDeps !(Map PackageName (Map PackageName (VersionIntervals, Maybe Version)))-  | FilepathInCustomSnapshot !Text-  | NeedResolverOrCompiler !Text-  | MissingPackages !(Set PackageName)-  | CustomResolverException !Text !(Either Request FilePath) !ParseException-  | InvalidStackageException !SnapName !String-  deriving Typeable-instance Exception SnapshotException-instance Show SnapshotException where-  show (InvalidCabalFileInSnapshot loc err) = concat-    [ "Invalid cabal file at "-    , show loc-    , ": "-    , show err-    ]-  show (PackageDefinedTwice name loc1 loc2) = concat-    [ "Package "-    , packageNameString name-    , " is defined twice, at "-    , show loc1-    , " and "-    , show loc2-    ]-  show (UnmetDeps m) =-      concat $ "Some dependencies in the snapshot are unmet.\n" : map go (Map.toList m)-    where-      go (name, deps) = concat-        $ "\n"-        : packageNameString name-        : " is missing:\n"-        : map goDep (Map.toList deps)--      goDep (dep, (intervals, mversion)) = concat-        [ "- "-        , packageNameString dep-        , ". Requires: "-        , display $ toVersionRange intervals-        , ", "-        , case mversion of-            Nothing -> "none present"-            Just version -> versionString version ++ " found"-        , "\n"-        ]-  show (FilepathInCustomSnapshot url) =-    "Custom snapshots do not support filepaths, as the contents may change over time. Found in: " ++-    T.unpack url-  show (NeedResolverOrCompiler url) =-    "You must specify either a resolver or compiler value in " ++-    T.unpack url-  show (MissingPackages names) =-    "The following packages specified by flags or options are not found: " ++-    unwords (map packageNameString (Set.toList names))-  show (CustomResolverException url loc e) = concat-    [ "Unable to load custom resolver "-    , T.unpack url-    , " from "-    , case loc of-        Left _req -> "HTTP request"-        Right fp -> "local file:\n  " ++ fp-    , "\nException: "-    , case e of-        AesonException s -> s-        _ -> show e-    ]-  show (InvalidStackageException snapName e) = concat-    [ "Unable to parse Stackage snapshot "-    , T.unpack (renderSnapName snapName)-    , ": "-    , e-    ]---- | Convert a 'Resolver' into a 'SnapshotDef'-loadResolver-  :: forall env. HasConfig env-  => Resolver-  -> RIO env SnapshotDef-loadResolver (ResolverStackage name) = do-    stackage <- view stackRootL-    file' <- parseRelFile $ T.unpack file-    cachePath <- (buildPlanCacheDir stackage </>) <$> parseRelFile (T.unpack (renderSnapName name <> ".cache"))-    let fp = buildPlanDir stackage </> file'-        tryDecode = tryAny $ $(versionedDecodeOrLoad snapshotDefVC) cachePath $ liftIO $ do-          evalue <- decodeFileEither $ toFilePath fp-          case evalue of-            Left e -> throwIO e-            Right value ->-              case parseEither parseStackageSnapshot value of-                Left s -> throwIO $ InvalidStackageException name s-                Right x -> return x-    logDebug $ "Decoding build plan from: " <> fromString (toFilePath fp)-    eres <- tryDecode-    case eres of-        Right sd -> return sd-        Left e -> do-            logDebug $-              "Decoding Stackage snapshot definition from file failed: " <>-              displayShow e-            ensureDir (parent fp)-            url <- buildBuildPlanUrl name file-            req <- parseRequest $ T.unpack url-            logSticky $ "Downloading " <> RIO.display name <> " build plan ..."-            logDebug $ "Downloading build plan from: " <> RIO.display url-            wasDownloaded <- redownload req fp-            if wasDownloaded-              then logStickyDone $ "Downloaded " <> RIO.display name <> " build plan."-              else logStickyDone $ "Skipped download of " <> RIO.display name <> " because its the stored entity tag matches the server version"-            tryDecode >>= either throwM return--  where-    file = renderSnapName name <> ".yaml"--    buildBuildPlanUrl :: (MonadReader env m, HasConfig env) => SnapName -> Text -> m Text-    buildBuildPlanUrl snapName file' = do-        urls <- view $ configL.to configUrls-        return $-            case snapName of-                LTS _ _ -> urlsLtsBuildPlans urls <> "/" <> file'-                Nightly _ -> urlsNightlyBuildPlans urls <> "/" <> file'--    parseStackageSnapshot = withObject "StackageSnapshotDef" $ \o -> do-        Object si <- o .: "system-info"-        ghcVersion <- si .:? "ghc-version"-        compilerVersion <- si .:? "compiler-version"-        compilerVersion' <--            case (ghcVersion, compilerVersion) of-                (Just _, Just _) -> fail "can't have both compiler-version and ghc-version fields"-                (Just ghc, _) -> return (GhcVersion ghc)-                (_, Just compiler) -> return compiler-                _ -> fail "expected field \"ghc-version\" or \"compiler-version\" not present"-        let sdParent = Left compilerVersion'-        sdGlobalHints <- si .: "core-packages"--        packages <- o .: "packages"-        (Endo mkLocs, sdFlags, sdHidden) <- fmap mconcat $ mapM (uncurry goPkg) $ Map.toList packages-        let sdLocations = mkLocs []--        let sdGhcOptions = Map.empty -- Stackage snapshots do not allow setting GHC options--        -- Not dropping any packages in a Stackage snapshot-        let sdDropPackages = Set.empty--        let sdResolver = ResolverStackage name-            sdResolverName = renderSnapName name--        return SnapshotDef {..}-      where-        goPkg name' = withObject "StackagePackageDef" $ \o -> do-            version <- o .: "version"-            mcabalFileInfo <- o .:? "cabal-file-info"-            mcabalFileInfo' <- forM mcabalFileInfo $ \o' -> do-                msize <- Just <$> o' .: "size"-                cfiHashes <- o' .: "hashes"-                hash' <--                  case HashMap.lookup ("SHA256" :: Text) cfiHashes of-                    Nothing -> fail "Could not find SHA256"-                    Just shaText ->-                      case mkCabalHashFromSHA256 shaText of-                        Left e -> fail $ "Invalid SHA256: " ++ show e-                        Right x -> return x-                return $ CFIHash msize hash'--            Object constraints <- o .: "constraints"--            flags <- constraints .: "flags"-            let flags' = Map.singleton name' flags--            hide <- constraints .:? "hide" .!= False-            let hide' = if hide then Map.singleton name' True else Map.empty--            let location = PLIndex $ PackageIdentifierRevision (PackageIdentifier name' version) (fromMaybe CFILatest mcabalFileInfo')--            return (Endo (location:), flags', hide')-loadResolver (ResolverCompiler compiler) = return SnapshotDef-    { sdParent = Left compiler-    , sdResolver = ResolverCompiler compiler-    , sdResolverName = compilerVersionText compiler-    , sdLocations = []-    , sdDropPackages = Set.empty-    , sdFlags = Map.empty-    , sdHidden = Map.empty-    , sdGhcOptions = Map.empty-    , sdGlobalHints = Map.empty-    }-loadResolver (ResolverCustom url loc) = do-  logDebug $ "Loading " <> RIO.display url <> " build plan from " <> displayShow loc-  case loc of-    Left req -> download' req >>= load . toFilePath-    Right fp -> load fp-  where-    download' :: Request -> RIO env (Path Abs File)-    download' req = do-      let urlHash = T.unpack $ trimmedSnapshotHash $ snapshotHashFromBS $ encodeUtf8 url-      hashFP <- parseRelFile $ urlHash ++ ".yaml"-      customPlanDir <- getCustomPlanDir-      let cacheFP = customPlanDir </> $(mkRelDir "yaml") </> hashFP-      void (download req cacheFP :: RIO env Bool)-      return cacheFP--    getCustomPlanDir = do-        root <- view stackRootL-        return $ root </> $(mkRelDir "custom-plan")--    load :: FilePath -> RIO env SnapshotDef-    load fp = do-      let resolveLocalArchives sd = sd {-            sdLocations = resolveLocalArchive <$> sdLocations sd-          }-          resolveLocalArchive (PLOther (PLArchive archive)) = -            PLOther $ PLArchive $ archive {-              archiveUrl = T.pack $ resolveLocalFilePath (T.unpack $ archiveUrl archive)-            }-          resolveLocalArchive pl = pl-          resolveLocalFilePath path =-            if isURI path || FilePath.isAbsolute path-              then path-              else FilePath.dropFileName fp FilePath.</> FilePath.normalise path--      WithJSONWarnings (sd0, mparentResolver, mcompiler) warnings <--        liftIO (decodeFileEither fp) >>= either-          (throwM . CustomResolverException url loc)-          (either (throwM . CustomResolverException url loc . AesonException) return . parseEither parseCustom)-      logJSONWarnings (T.unpack url) warnings-      forM_ (sdLocations sd0) $ \loc' ->-        case loc' of-          PLOther (PLFilePath _) -> throwM $ FilepathInCustomSnapshot url-          _ -> return ()-      let sd0' = resolveLocalArchives sd0-      -- The fp above may just be the download location for a URL,-      -- which we don't want to use. Instead, look back at loc from-      -- above.-      mdir <--        case loc of-          Left _ -> return Nothing-          Right fp' -> Just . parent <$> liftIO (Dir.canonicalizePath fp' >>= parseAbsFile)--      -- Deal with the dual nature of the compiler key, which either-      -- means "use this compiler" or "override the compiler in the-      -- resolver"-      (parentResolver, overrideCompiler) <--        case (mparentResolver, mcompiler) of-          (Nothing, Nothing) -> throwM $ NeedResolverOrCompiler url-          (Just parentResolver, Nothing) -> return (parentResolver, id)-          (Nothing, Just compiler) -> return (ResolverCompiler compiler, id)-          (Just parentResolver, Just compiler) -> return-            ( parentResolver-            , setCompilerVersion compiler-            )--      parentResolver' <- parseCustomLocation mdir parentResolver--      -- Calculate the hash of the current file, and then combine it-      -- with parent hashes if necessary below.-      rawHash :: SnapshotHash <- snapshotHashFromDigest <$> hashFile fp :: RIO env SnapshotHash--      (parent', hash') <--        case parentResolver' of-          ResolverCompiler cv -> return (Left cv, rawHash) -- just a small optimization-          _ -> do-            parent' :: SnapshotDef <- loadResolver (parentResolver' :: Resolver) :: RIO env SnapshotDef-            let hash' :: SnapshotHash-                hash' = combineHash rawHash $-                  case sdResolver parent' of-                    ResolverStackage snapName -> snapNameToHash snapName-                    ResolverCustom _ parentHash -> parentHash-                    ResolverCompiler _ -> error "loadResolver: Received ResolverCompiler in impossible location"-            return (Right parent', hash')-      return $ overrideCompiler sd0'-        { sdParent = parent'-        , sdResolver = ResolverCustom url hash'-        }--    -- | Note that the 'sdParent' and 'sdResolver' fields returned-    -- here are bogus, and need to be replaced with information only-    -- available after further processing.-    parseCustom :: Value-                -> Parser (WithJSONWarnings (SnapshotDef, Maybe (ResolverWith ()), Maybe (CompilerVersion 'CVWanted)))-    parseCustom = withObjectWarnings "CustomSnapshot" $ \o -> (,,)-        <$> (SnapshotDef (Left (error "loadResolver")) (ResolverStackage (LTS 0 0))-            <$> (o ..: "name")-            <*> jsonSubWarningsT (o ..:? "packages" ..!= [])-            <*> o ..:? "drop-packages" ..!= Set.empty-            <*> o ..:? "flags" ..!= Map.empty-            <*> o ..:? "hidden" ..!= Map.empty-            <*> o ..:? "ghc-options" ..!= Map.empty-            <*> o ..:? "global-hints" ..!= Map.empty)-        <*> (o ..:? "resolver")-        <*> (o ..:? "compiler")--    combineHash :: SnapshotHash -> SnapshotHash -> SnapshotHash-    combineHash x y = snapshotHashFromBS (snapshotHashToBS x <> snapshotHashToBS y)--    snapNameToHash :: SnapName -> SnapshotHash-    snapNameToHash = snapshotHashFromBS . encodeUtf8 . renderSnapName---- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot'-loadSnapshot-  :: forall env.-     (HasConfig env, HasGHCVariant env)-  => Maybe (CompilerVersion 'CVActual) -- ^ installed GHC we should query; if none provided, use the global hints-  -> Path Abs Dir -- ^ project root, used for checking out necessary files-  -> SnapshotDef-  -> RIO env LoadedSnapshot-loadSnapshot mcompiler root =-    start-  where-    start (snapshotDefFixes -> sd) = do-      path <- configLoadedSnapshotCache-        sd-        (maybe GISSnapshotHints GISCompiler mcompiler)-      $(versionedDecodeOrLoad loadedSnapshotVC) path (inner sd)--    inner :: SnapshotDef -> RIO env LoadedSnapshot-    inner sd = do-      ls0 <--        case sdParent sd of-          Left cv ->-            case mcompiler of-              Nothing -> return LoadedSnapshot-                { lsCompilerVersion = wantedToActual cv-                , lsGlobals = fromGlobalHints $ sdGlobalHints sd-                , lsPackages = Map.empty-                }-              Just cv' -> loadCompiler cv'-          Right sd' -> start sd'--      gpds <--        (concat <$> mapM (parseMultiCabalFilesIndex root) (sdLocations sd))-        `onException` do-          logError "Unable to load cabal files for snapshot"-          case sdResolver sd of-            ResolverStackage name -> do-              stackRoot <- view stackRootL-              file <- parseRelFile $ T.unpack $ renderSnapName name <> ".yaml"-              let fp = buildPlanDir stackRoot </> file-              liftIO $ ignoringAbsence $ removeFile fp-              logError ""-              logError "----"-              logError $ "Deleting cached snapshot file: " <> fromString (toFilePath fp)-              logError "Recommendation: try running again. If this fails again, open an upstream issue at:"-              logError $-                case name of-                  LTS _ _ -> "https://github.com/fpco/lts-haskell/issues/new"-                  Nightly _ -> "https://github.com/fpco/stackage-nightly/issues/new"-              logError "----"-              logError ""-            _ -> return ()--      (globals, snapshot, locals) <--        calculatePackagePromotion root ls0-        (map (\(x, y) -> (x, y, ())) gpds)-        (sdFlags sd) (sdHidden sd) (sdGhcOptions sd) (sdDropPackages sd)--      return LoadedSnapshot-        { lsCompilerVersion = lsCompilerVersion ls0-        , lsGlobals = globals-        -- When applying a snapshot on top of another one, we merge-        -- the two snapshots' packages together.-        , lsPackages = Map.union snapshot (Map.map (fmap fst) locals)-        }---- | Given information on a 'LoadedSnapshot' and a given set of--- additional packages and configuration values, calculates the new--- global and snapshot packages, as well as the new local packages.------ The new globals and snapshots must be a subset of the initial--- values.-calculatePackagePromotion-  :: forall env localLocation.-     (HasConfig env, HasGHCVariant env)-  => Path Abs Dir -- ^ project root-  -> LoadedSnapshot-  -> [(GenericPackageDescription, SinglePackageLocation, localLocation)] -- ^ packages we want to add on top of this snapshot-  -> Map PackageName (Map FlagName Bool) -- ^ flags-  -> Map PackageName Bool -- ^ overrides whether a package should be registered hidden-  -> Map PackageName [Text] -- ^ GHC options-  -> Set PackageName -- ^ packages in the snapshot to drop-  -> RIO env-       ( Map PackageName (LoadedPackageInfo GhcPkgId) -- new globals-       , Map PackageName (LoadedPackageInfo SinglePackageLocation) -- new snapshot-       , Map PackageName (LoadedPackageInfo (SinglePackageLocation, Maybe localLocation)) -- new locals-       )-calculatePackagePromotion-  root (LoadedSnapshot compilerVersion globals0 parentPackages0)-  gpds flags0 hides0 options0 drops0 = do--      platform <- view platformL--      -- Hand out flags, hide, and GHC options to the newly added-      -- packages-      (packages1, flags, hide, ghcOptions) <- execStateT-        (mapM_ (findPackage platform compilerVersion) gpds)-        (Map.empty, flags0, hides0, options0)--      let-          -- We need to drop all packages from globals and parent-          -- packages that are either marked to be dropped, or-          -- included in the new packages.-          toDrop = Map.union (void packages1) (Map.fromSet (const ()) drops0)-          globals1 = Map.difference globals0 toDrop-          parentPackages1 = Map.difference parentPackages0 toDrop--          -- The set of all packages that need to be upgraded based on-          -- newly set flags, hide values, or GHC options-          toUpgrade = Set.unions [Map.keysSet flags, Map.keysSet hide, Map.keysSet ghcOptions]--          -- Perform a sanity check: ensure that all of the packages-          -- that need to be upgraded actually exist in the global or-          -- parent packages-          oldNames = Set.union (Map.keysSet globals1) (Map.keysSet parentPackages1)-          extraToUpgrade = Set.difference toUpgrade oldNames-      unless (Set.null extraToUpgrade) $ throwM $ MissingPackages extraToUpgrade--      let-          -- Split up the globals into those that are to be upgraded-          -- (no longer globals) and those that remain globals, based-          -- solely on the toUpgrade value-          (noLongerGlobals1, globals2) = Map.partitionWithKey-            (\name _ -> name `Set.member` toUpgrade)-            globals1-          -- Further: now that we've removed a bunch of packages from-          -- globals, split out any packages whose dependencies are no-          -- longer met-          (globals3, noLongerGlobals2) = splitUnmetDeps Map.empty globals2--          -- Put together the two split out groups of packages-          noLongerGlobals3 :: Map PackageName (LoadedPackageInfo SinglePackageLocation)-          noLongerGlobals3 = Map.mapWithKey globalToSnapshot (Map.union noLongerGlobals1 noLongerGlobals2)--          -- Now do the same thing with parent packages: take out the-          -- packages to be upgraded and then split out unmet-          -- dependencies.-          (noLongerParent1, parentPackages2) = Map.partitionWithKey-            (\name _ -> name `Set.member` toUpgrade)-            parentPackages1-          (parentPackages3, noLongerParent2) = splitUnmetDeps-            (Map.map lpiVersion globals3)-            parentPackages2-          noLongerParent3 = Map.union noLongerParent1 noLongerParent2--          -- Everything split off from globals and parents will be upgraded...-          allToUpgrade = Map.union noLongerGlobals3 noLongerParent3--      -- ... so recalculate based on new values-      upgraded <- fmap Map.fromList-                $ mapM (recalculate root compilerVersion flags hide ghcOptions)-                $ Map.toList allToUpgrade--      -- Could be nice to check snapshot early... but disabling-      -- because ConstructPlan gives much nicer error messages-      let packages2 = Map.unions [Map.map void upgraded, Map.map void packages1, Map.map void parentPackages3]-          allAvailable = Map.union-            (lpiVersion <$> globals3)-            (lpiVersion <$> packages2)-      when False $ checkDepsMet allAvailable packages2--      unless (Map.null (globals3 `Map.difference` globals0))-        (error "calculatePackagePromotion: subset invariant violated for globals")-      unless (Map.null (parentPackages3 `Map.difference` parentPackages0))-        (error "calculatePackagePromotion: subset invariant violated for parents")--      return-        ( globals3-        , parentPackages3-        , Map.union (Map.map (fmap (, Nothing)) upgraded) (Map.map (fmap (second Just)) packages1)-        )---- | Recalculate a 'LoadedPackageInfo' based on updates to flags,--- hide values, and GHC options.-recalculate :: forall env.-               (HasConfig env, HasGHCVariant env)-            => Path Abs Dir -- ^ root-            -> CompilerVersion 'CVActual-            -> Map PackageName (Map FlagName Bool)-            -> Map PackageName Bool -- ^ hide?-            -> Map PackageName [Text] -- ^ GHC options-            -> (PackageName, LoadedPackageInfo SinglePackageLocation)-            -> RIO env (PackageName, LoadedPackageInfo SinglePackageLocation)-recalculate root compilerVersion allFlags allHide allOptions (name, lpi0) = do-  let hide = fromMaybe (lpiHide lpi0) (Map.lookup name allHide)-      options = fromMaybe (lpiGhcOptions lpi0) (Map.lookup name allOptions)-  case Map.lookup name allFlags of-    Nothing -> return (name, lpi0 { lpiHide = hide, lpiGhcOptions = options }) -- optimization-    Just flags -> do-      let loc = lpiLocation lpi0-      gpd <- parseSingleCabalFileIndex root loc-      platform <- view platformL-      let res@(name', lpi) = calculate gpd platform compilerVersion loc flags hide options-      unless (name == name' && lpiVersion lpi0 == lpiVersion lpi) $ error "recalculate invariant violated"-      return res--fromGlobalHints :: Map PackageName (Maybe Version) -> Map PackageName (LoadedPackageInfo GhcPkgId)-fromGlobalHints =-    Map.unions . map go . Map.toList-  where-    go (_, Nothing) = Map.empty-    go (name, Just ver) = Map.singleton name LoadedPackageInfo-      { lpiVersion = ver-      -- For global hint purposes, we only care about the-      -- version. All other fields are ignored when checking-      -- project compatibility.-      , lpiLocation = either impureThrow id-                    $ parseGhcPkgId-                    $ packageIdentifierText-                    $ PackageIdentifier name ver-      , lpiFlags = Map.empty-      , lpiGhcOptions = []-      , lpiPackageDeps = Map.empty-      , lpiExposedModules = Set.empty-      , lpiHide = False-      }---- | Ensure that all of the dependencies needed by this package--- are available in the given Map of packages.-checkDepsMet :: MonadThrow m-             => Map PackageName Version -- ^ all available packages-             -> Map PackageName (LoadedPackageInfo localLocation)-             -> m ()-checkDepsMet available m-  | Map.null errs = return ()-  | otherwise = throwM $ UnmetDeps errs-  where-    errs = foldMap (uncurry go) (Map.toList m)--    go :: PackageName-       -> LoadedPackageInfo loc-       -> Map PackageName (Map PackageName (VersionIntervals, Maybe Version))-    go name lpi-      | Map.null errs' = Map.empty-      | otherwise = Map.singleton name errs'-      where-        errs' = foldMap (uncurry goDep) (Map.toList (lpiPackageDeps lpi))--    goDep :: PackageName -> VersionIntervals -> Map PackageName (VersionIntervals, Maybe Version)-    goDep name intervals =-      case Map.lookup name available of-        Nothing -> Map.singleton name (intervals, Nothing)-        Just version-          | version `withinIntervals` intervals -> Map.empty-          | otherwise -> Map.singleton name (intervals, Just version)---- | Load a snapshot from the given compiler version, using just the--- information in the global package database.-loadCompiler :: forall env.-                HasConfig env-             => CompilerVersion 'CVActual-             -> RIO env LoadedSnapshot-loadCompiler cv = do-  m <- ghcPkgDump (whichCompiler cv) []-    (conduitDumpPackage .| CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp))-  return LoadedSnapshot-    { lsCompilerVersion = cv-    , lsGlobals = toGlobals m-    , lsPackages = Map.empty-    }-  where-    toGlobals :: Map GhcPkgId (DumpPackage () () ())-              -> Map PackageName (LoadedPackageInfo GhcPkgId)-    toGlobals m =-        Map.fromList $ map go $ Map.elems m-      where-        identMap = Map.map dpPackageIdent m--        go :: DumpPackage () () () -> (PackageName, LoadedPackageInfo GhcPkgId)-        go dp =-            (name, lpi)-          where-            PackageIdentifier name version = dpPackageIdent dp--            goDep ghcPkgId =-              case Map.lookup ghcPkgId identMap of-                Nothing -> Map.empty-                Just (PackageIdentifier name' _) -> Map.singleton name' (fromVersionRange C.anyVersion)--            lpi :: LoadedPackageInfo GhcPkgId-            lpi = LoadedPackageInfo-                { lpiVersion = version-                , lpiLocation = dpGhcPkgId dp-                , lpiFlags = Map.empty-                , lpiGhcOptions = []-                , lpiPackageDeps = Map.unions $ map goDep $ dpDepends dp-                , lpiExposedModules = Set.fromList $ map (ModuleName . encodeUtf8) $ dpExposedModules dp-                , lpiHide = not $ dpIsExposed dp-                }--type FindPackageS localLocation =-    ( Map PackageName (LoadedPackageInfo (SinglePackageLocation, localLocation))-    , Map PackageName (Map FlagName Bool) -- flags-    , Map PackageName Bool -- hide-    , Map PackageName [Text] -- ghc options-    )---- | Find the package at the given 'PackageLocation', grab any flags,--- hidden state, and GHC options from the 'StateT' (removing them from--- the 'StateT'), and add the newly found package to the contained--- 'Map'.-findPackage :: forall m localLocation.-               MonadThrow m-            => Platform-            -> CompilerVersion 'CVActual-            -> (GenericPackageDescription, SinglePackageLocation, localLocation)-            -> StateT (FindPackageS localLocation) m ()-findPackage platform compilerVersion (gpd, loc, localLoc) = do-    (m, allFlags, allHide, allOptions) <- get--    case Map.lookup name m of-      Nothing -> return ()-      Just lpi -> throwM $ PackageDefinedTwice name loc (fst (lpiLocation lpi))--    let flags = fromMaybe Map.empty $ Map.lookup name allFlags-        allFlags' = Map.delete name allFlags--        hide = fromMaybe False $ Map.lookup name allHide-        allHide' = Map.delete name allHide--        options = fromMaybe [] $ Map.lookup name allOptions-        allOptions' = Map.delete name allOptions--        (name', lpi) = calculate gpd platform compilerVersion (loc, localLoc) flags hide options-        m' = Map.insert name lpi m--    assert (name == name') $ put (m', allFlags', allHide', allOptions')-  where-    PackageIdentifier name _version = fromCabalPackageIdentifier $ C.package $ C.packageDescription gpd---- | Some hard-coded fixes for build plans, only for hysterical raisins.-snapshotDefFixes :: SnapshotDef -> SnapshotDef-snapshotDefFixes sd | isOldStackage (sdResolver sd) = sd-    { sdFlags = Map.unionWith Map.union overrides $ sdFlags sd-    }-  where-    overrides = Map.fromList-      [ ($(mkPackageName "persistent-sqlite"), Map.singleton $(mkFlagName "systemlib") False)-      , ($(mkPackageName "yaml"), Map.singleton $(mkFlagName "system-libyaml") False)-      ]--    -- Only apply this hack to older Stackage snapshots. In-    -- particular, nightly-2018-03-13 did not contain these two-    -- packages.-    isOldStackage (ResolverStackage (LTS major _)) = major < 11-    isOldStackage (ResolverStackage (Nightly (toGregorian -> (year, _, _)))) = year < 2018-    isOldStackage _ = False-snapshotDefFixes sd = sd---- | Convert a global 'LoadedPackageInfo' to a snapshot one by--- creating a 'PackageLocation'.-globalToSnapshot :: PackageName -> LoadedPackageInfo loc -> LoadedPackageInfo (PackageLocationIndex FilePath)-globalToSnapshot name lpi = lpi-    { lpiLocation = PLIndex (PackageIdentifierRevision (PackageIdentifier name (lpiVersion lpi)) CFILatest)-    }---- | Split the packages into those which have their dependencies met,--- and those that don't. The first argument is packages that are known--- to be available for use as a dependency. The second argument is the--- packages to check.------ This works by repeatedly iterating through the list of input--- packages, adding any that have their dependencies satisfied to a map--- (eventually this set is the fst of the result tuple). Once an--- iteration completes without adding anything to this set, it knows it--- has found everything that has its dependencies met, and exits.-splitUnmetDeps :: Map PackageName Version -- ^ extra dependencies available-               -> Map PackageName (LoadedPackageInfo loc)-               -> ( Map PackageName (LoadedPackageInfo loc)-                  , Map PackageName (LoadedPackageInfo loc)-                  )-splitUnmetDeps extra =-    start Map.empty . Map.toList-  where-    start newGlobals0 toProcess0-      | anyAdded = start newGlobals1 toProcess1-      | otherwise = (newGlobals1, Map.fromList toProcess1)-      where-        (newGlobals1, toProcess1, anyAdded) = loop False newGlobals0 id toProcess0--    loop anyAdded newGlobals front [] = (newGlobals, front [], anyAdded)-    loop anyAdded newGlobals front (x@(k, v):xs)-      | depsMet newGlobals v = loop True (Map.insert k v newGlobals) front xs-      | otherwise = loop anyAdded newGlobals (front . (x:)) xs--    depsMet globals = all (depsMet' globals) . Map.toList . lpiPackageDeps--    -- MSS 2018-01-10. Previously, we would actually perform a version-    -- bounds check at this point. I believe this is a mistake: we-    -- don't want to promote a package from a snapshot to a local just-    -- because the version ranges aren't satisfied. In fact, we-    -- intentionally allow snapshots to specify mismatched versions of-    -- packages, and try building anyway.-    ---    -- With the old behavior: a number of packages would be converted-    -- and treated as local packages. I specifically stumbled on this-    -- while investigating Stackage issues #3185, where a revision to-    -- semigroupoids's tagged dependency caused the builds to-    -- break. Stack should have just ignored this and printed a-    -- warning. Instead, Stack believed that semigroupoids was a local-    -- package, not a snapshot package, and failed.-    ---    -- All that said: I'm pretty certain this is the right behavior,-    -- but all of this is strongly indicating that we need some code-    -- cleanup around this promotion business. I don't think I did a-    -- particularly good job on this code during the extensible-    -- snapshot rewrite.-    depsMet' globals (name, _intervals) =-      case (lpiVersion <$> Map.lookup name globals) <|> Map.lookup name extra of-        -- The dependency doesn't exist at all in the snapshot or-        -- extra, therefore this package must be promoted to local as-        -- well.-        Nothing -> False-        -- It exists. As explained above, don't bother checking the-        -- version bounds, we trust the snapshot.-        Just _version -> True---- | Calculate a 'LoadedPackageInfo' from the given 'GenericPackageDescription'-calculate :: GenericPackageDescription-          -> Platform-          -> CompilerVersion 'CVActual-          -> loc-          -> Map FlagName Bool-          -> Bool -- ^ hidden?-          -> [Text] -- ^ GHC options-          -> (PackageName, LoadedPackageInfo loc)-calculate gpd platform compilerVersion loc flags hide options =-    (name, lpi)-  where-    pconfig = PackageConfig-      { packageConfigEnableTests = False-      , packageConfigEnableBenchmarks = False-      , packageConfigFlags = flags-      , packageConfigGhcOptions = options-      , packageConfigCompilerVersion = compilerVersion-      , packageConfigPlatform = platform-      }-    -- We want to ignore test suites and benchmarks, therefore choose-    -- the package description which modifies buildable-    pd = pdpModifiedBuildable $ resolvePackageDescription pconfig gpd-    PackageIdentifier name version = fromCabalPackageIdentifier $ C.package pd-    lpi = LoadedPackageInfo-      { lpiVersion = version-      , lpiLocation = loc-      , lpiFlags = flags-      , lpiGhcOptions = options-      , lpiPackageDeps = Map.map fromVersionRange-                       $ Map.filterWithKey (const . (/= name))-                       $ packageDependencies pconfig pd-      , lpiExposedModules = maybe-          Set.empty-          (Set.fromList . map fromCabalModuleName . C.exposedModules)-          (C.library pd)-      , lpiHide = hide-      }
− src/Stack/Solver.hs 
@@ -1,799 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeFamilies          #-}-module Stack.Solver-    ( cabalPackagesCheck-    , findCabalDirs-    , getResolverConstraints-    , mergeConstraints-    , solveExtraDeps-    , solveResolverSpec-    , checkSnapBuildPlanActual-    -- * Internal - for tests-    , parseCabalOutputLine-    ) where--import           Stack.Prelude hiding (Display (..))-import           Data.Aeson.Extended         (object, (.=), toJSON)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as BL-import           Data.Char (isSpace)-import           Data.Conduit.Process.Typed (eceStderr)-import qualified Data.HashMap.Strict as HashMap-import qualified Data.HashSet as HashSet-import           Data.List                   ( (\\), isSuffixOf-                                             , minimumBy, isPrefixOf-                                             , intersperse)-import           Data.List.Extra (groupSortOn)-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Text as T-import           Data.Text.Encoding (decodeUtf8, encodeUtf8)-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           Path-import           Path.Find (findFiles)-import           Path.IO hiding (findExecutable, findFiles, withSystemTempDir)-import qualified RIO-import           Stack.Build.Target (gpdVersion)-import           Stack.BuildPlan-import           Stack.Config (getLocalPackages, loadConfigYaml)-import           Stack.Constants (stackDotYaml, wiredInPackages)-import           Stack.Package               (readPackageUnresolvedDir, gpdPackageName)-import           Stack.PackageIndex-import           Stack.PrettyPrint-import           Stack.Setup-import           Stack.Setup.Installed-import           Stack.Snapshot (loadSnapshot)-import           Stack.Types.Build-import           Stack.Types.BuildPlan-import           Stack.Types.Compiler-import           Stack.Types.Config-import           Stack.Types.FlagName-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Resolver-import           Stack.Types.Version-import qualified System.Directory as D-import qualified System.FilePath as FP-import           RIO.Process-import           Text.Regex.Applicative.Text (match, sym, psym, anySym, few)--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 :: HasConfig env-            => [Path Abs Dir] -- ^ cabal files-            -> ConstraintType-            -> ConstraintSpec -- ^ src constraints-            -> ConstraintSpec -- ^ dep constraints-            -> [String] -- ^ additional arguments-            -> RIO env (Either [PackageName] ConstraintSpec)-cabalSolver cabalfps constraintType-            srcConstraints depConstraints cabalArgs =-  withSystemTempDir "cabal-solver" $ \dir' -> do--    let versionConstraints = fmap fst depConstraints-        dir = toFilePath dir'-    configLines <- getCabalConfig dir constraintType versionConstraints-    let configFile = dir FP.</> "cabal.config"-    liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines--    -- Run from a temporary directory to avoid cabal getting confused by any-    -- sandbox files, see:-    -- https://github.com/commercialhaskell/stack/issues/356-    ---    -- In theory we could use --ignore-sandbox, but not all versions of cabal-    -- support it.-    tmpdir <- getTempDir--    let args = ("--config-file=" ++ configFile)-             : "install"-             : "--enable-tests"-             : "--enable-benchmarks"-             : "--dry-run"-             : "--reorder-goals"-             : "--max-backjumps=-1"-             : "--package-db=clear"-             : "--package-db=global"-             : cabalArgs ++-               toConstraintArgs (flagConstraints constraintType) ++-               fmap toFilePath cabalfps--    try ( withWorkingDir (toFilePath tmpdir)-        $ proc "cabal" args readProcess_-        )-        >>= either-          (parseCabalErrors . eceStderr)-          (parseCabalOutput . BL.toStrict . fst)--  where-    errCheck = T.isInfixOf "Could not resolve dependencies"-    linesNoCR = map stripCR . T.lines-    cabalBuildErrMsg e =-               ">>>> Cabal errors begin\n"-            <> e-            <> "<<<< Cabal errors end\n"--    parseCabalErrors err = do-        let errExit e = error $ "Could not parse cabal-install errors:\n\n"-                              ++ cabalBuildErrMsg (T.unpack e)-            msg = decodeUtf8With lenientDecode $ toStrictBytes err--        if errCheck msg then do-            logInfo "Attempt failed.\n"-            logInfo $ RIO.display $ cabalBuildErrMsg msg-            let pkgs = parseConflictingPkgs msg-                mPkgNames = map (C.simpleParse . T.unpack) pkgs-                pkgNames  = map (fromCabalPackageName . C.pkgName)-                                (catMaybes mPkgNames)--            when (any isNothing mPkgNames) $ do-                  logInfo $ "*** Only some package names could be parsed: " <>-                      mconcat (intersperse ", " (map displayShow pkgNames))-                  error $ T.unpack $-                       "*** User packages involved in cabal failure: "-                       <> T.intercalate ", " (parseConflictingPkgs msg)--            if pkgNames /= [] then do-                  return $ Left pkgNames-            else errExit msg-        else errExit msg--    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-                      . T.words-                      . T.drop 1-                      . T.dropWhile (/= ':')-        in concatMap pkgName (filter select ls)--    parseCabalOutput bs = do-        let ls = drop 1-               $ dropWhile (not . T.isPrefixOf "In order, ")-               $ linesNoCR-               $ decodeUtf8With lenientDecode bs-            (errs, pairs) = partitionEithers $ map parseCabalOutputLine ls-        if null errs-          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)--    toConstraintArgs userFlagMap =-        [formatFlagConstraint package flag enabled-            | (package, fs) <- Map.toList userFlagMap-            , (flag, enabled) <- Map.toList fs]--    formatFlagConstraint package flag enabled =-        let sign = if enabled then '+' else '-'-        in-        "--constraint=" ++ unwords [packageNameString package, sign : flagNameString flag]--    -- Note the order of the Map union is important-    -- We override a package in snapshot by a src package-    flagConstraints Constraint = fmap snd (Map.union srcConstraints-                                           depConstraints)-    -- Even when using preferences we want to-    -- keep the src package flags unchanged-    -- TODO - this should be done only for manual flags.-    flagConstraints Preference = fmap snd srcConstraints---    -- An ugly parser to extract module id and flags-parseCabalOutputLine :: Text -> Either Text (PackageName, (Version, Map FlagName Bool))-parseCabalOutputLine t0 = maybe (Left t0) Right . join .  match re $ t0-    -- Sample outputs to parse:-    -- text-1.2.1.1 (latest: 1.2.2.0) -integer-simple (via: parsec-3.1.9) (new package))-    -- hspec-snap-1.0.0.0 *test (via: servant-snap-0.5) (new package)-    -- time-locale-compat-0.1.1.1 -old-locale (via: http-api-data-0.2.2) (new package))-    -- flowdock-rest-0.2.0.0 -aeson-compat *test (via: haxl-fxtra-0.0.0.0) (new package)-  where-    re = mk <$> some (psym $ not . isSpace) <*> many (lexeme reMaybeFlag)--    reMaybeFlag =-        (\s -> Just (True, s))  <$ sym '+' <*> some (psym $ not . isSpace) <|>-        (\s -> Just (False, s)) <$ sym '-' <*> some (psym $ not . isSpace) <|>-        Nothing <$ sym '*' <* some (psym $ not . isSpace) <|>-        Nothing <$ sym '(' <* few anySym <* sym ')'--    mk :: String -> [Maybe (Bool, String)] -> Maybe (PackageName, (Version, Map FlagName Bool))-    mk ident fl = do-        PackageIdentifier name version <--            parsePackageIdentifierFromString ident-        fl' <- (traverse . traverse) parseFlagNameFromString $ catMaybes fl-        return (name, (version, Map.fromList $ map swap fl'))--    lexeme r = some (psym isSpace) *> r--getCabalConfig :: HasConfig env-               => FilePath -- ^ temp dir-               -> ConstraintType-               -> Map PackageName Version -- ^ constraints-               -> RIO env [Text]-getCabalConfig dir constraintType constraints = do-    indices <- view $ cabalLoaderL.to clIndices-    remotes <- mapM goIndex indices-    let cache = T.pack $ "remote-repo-cache: " ++ dir-    return $ cache : remotes ++ map goConstraint (Map.toList constraints)-  where-    goIndex index = do-        src <- configPackageIndex $ indexName index-        let dstdir = dir FP.</> T.unpack (indexNameText $ indexName index)-            -- NOTE: see https://github.com/commercialhaskell/stack/issues/2888-            -- for why we are pretending that a 01-index.tar is actually a-            -- 00-index.tar file.-            dst0 = dstdir FP.</> "00-index.tar"-            dst1 = dstdir FP.</> "01-index.tar"-        liftIO $ void $ tryIO $ do-            D.createDirectoryIfMissing True dstdir-            D.copyFile (toFilePath src) dst0-            D.copyFile (toFilePath src) dst1-        return $ T.concat-            [ "remote-repo: "-            , indexNameText $ indexName index-            , ":http://0.0.0.0/fake-url"-            ]--    goConstraint (name, version) =-        assert (not . null . versionString $ version) $-            T.concat-              [ if constraintType == Constraint-                   || name `HashSet.member` wiredInPackages-                then "constraint: "-                else "preference: "-              , T.pack $ packageNameString name-              , "=="-              , T.pack $ versionString version-              ]--setupCompiler-    :: (HasConfig env, HasGHCVariant env)-    => CompilerVersion 'CVWanted-    -> RIO env (Maybe ExtraDirs)-setupCompiler compiler = do-    let msg = Just $ T.concat-          [ "Compiler version (" <> compilerVersionText compiler <> ") "-          , "required by your resolver specification cannot be found.\n\n"-          , "Please use '--install-ghc' command line switch to automatically "-          , "install the compiler or '--system-ghc' to use a suitable "-          , "compiler available on your PATH." ]--    config <- view configL-    (dirs, _, _) <- ensureCompiler SetupOpts-        { soptsInstallIfMissing  = configInstallGHC config-        , soptsUseSystem         = configSystemGHC config-        , soptsWantedCompiler    = compiler-        , soptsCompilerCheck     = configCompilerCheck config-        , soptsStackYaml         = Nothing-        , soptsForceReinstall    = False-        , soptsSanityCheck       = False-        , soptsSkipGhcCheck      = False-        , soptsSkipMsys          = configSkipMsys config-        , soptsUpgradeCabal      = Nothing-        , soptsResolveMissingGHC = msg-        , soptsSetupInfoYaml     = defaultSetupInfoYaml-        , soptsGHCBindistURL     = Nothing-        , soptsGHCJSBootOpts     = ["--clean"]-        }-    return dirs---- | Runs the given inner command with an updated configuration that--- has the desired GHC on the PATH.-setupCabalEnv-    :: (HasConfig env, HasGHCVariant env)-    => CompilerVersion 'CVWanted-    -> (CompilerVersion 'CVActual -> RIO env a)-    -> RIO env a-setupCabalEnv compiler inner = do-  mpaths <- setupCompiler compiler-  menv0 <- view processContextL-  envMap <- either throwM (return . removeHaskellEnvVars)-              $ augmentPathMap (toFilePath <$> maybe [] edBins mpaths)-                               (view envVarsL menv0)-  menv <- mkProcessContext envMap-  withProcessContext menv $ do-    mcabal <- getCabalInstallVersion-    case mcabal of-        Nothing -> throwM SolverMissingCabalInstall-        Just version-            | version < $(mkVersion "1.24") -> prettyWarn $-                "Installed version of cabal-install (" <>-                display version <>-                ") doesn't support custom-setup clause, and so may not yield correct results." <> line <>-                "To resolve this, install a newer version via 'stack install cabal-install'." <> line-            | version >= $(mkVersion "1.25") -> prettyWarn $-                "Installed version of cabal-install (" <>-                display version <>-                ") is newer than stack has been tested with.  If you run into difficulties, consider downgrading." <> line-            | otherwise -> return ()--    mver <- getSystemCompiler (whichCompiler compiler)-    version <- case mver of-        Just (version, _) -> do-            logInfo $ "Using compiler: " <> RIO.display version-            return version-        Nothing -> error "Failed to determine compiler version. \-                         \This is most likely a bug."--    inner version---- | Merge two separate maps, one defining constraints on package versions and--- the other defining package flagmap, into a single map of version and flagmap--- tuples.-mergeConstraints-    :: Map PackageName v-    -> Map PackageName (Map p f)-    -> Map PackageName (v, Map p f)-mergeConstraints = Map.mergeWithKey-    -- combine entry in both maps-    (\_ v f -> Just (v, f))-    -- convert entry in first map only-    (fmap (, Map.empty))-    -- convert entry in second map only-    (\m -> if Map.null m then Map.empty-           else error "Bug: An entry in flag map must have a corresponding \-                      \entry in the version map")---- | Given a resolver, user package constraints (versions and flags) and extra--- dependency constraints determine what extra dependencies are required--- outside the resolver snapshot and the specified extra dependencies.------ First it tries by using the snapshot and the input extra dependencies--- as hard constraints, if no solution is arrived at by using hard--- constraints it then tries using them as soft constraints or preferences.------ It returns either conflicting packages when no solution is arrived at--- or the solution in terms of src package flag settings and extra--- dependencies.-solveResolverSpec-    :: (HasConfig env, HasGHCVariant env)-    => Path Abs File  -- ^ stack.yaml file location-    -> [Path Abs Dir] -- ^ package dirs containing cabal files-    -> ( SnapshotDef-       , ConstraintSpec-       , ConstraintSpec) -- ^ ( resolver-                         --   , src package constraints-                         --   , extra dependency constraints )-    -> RIO env-         (Either [PackageName] (ConstraintSpec , ConstraintSpec))-       -- ^ (Conflicting packages-       --    (resulting src package specs, external dependency specs))--solveResolverSpec stackYaml cabalDirs-                  (sd, srcConstraints, extraConstraints) = do-  logInfo $ "Using resolver: " <> RIO.display (sdResolverName sd)-  let wantedCompilerVersion = sdWantedCompilerVersion sd-  setupCabalEnv wantedCompilerVersion $ \compilerVersion -> do-    (compilerVer, snapConstraints) <- getResolverConstraints (Just compilerVersion) stackYaml sd--    let -- Note - The order in Map.union below is important.-        -- We want to override snapshot with extra deps-        depConstraints = Map.union extraConstraints snapConstraints-        -- Make sure to remove any user packages from the dep constraints-        -- There are two reasons for this:-        -- 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 cabalDirs t srcConstraints depOnlyConstraints $-                     "-v" : -- TODO make it conditional on debug-                     ["--ghcjs" | whichCompiler compilerVer == Ghcjs]--    let srcNames = T.intercalate " and " $-          ["packages from " <> sdResolverName sd-              | not (Map.null snapConstraints)] ++-          [T.pack (show (Map.size extraConstraints) <> " external packages")-              | not (Map.null extraConstraints)]--    logInfo "Asking cabal to calculate a build plan..."-    unless (Map.null depOnlyConstraints)-        (logInfo $ "Trying with " <> RIO.display srcNames <> " as hard constraints...")--    eresult <- solver Constraint-    eresult' <- case eresult of-        Left _ | not (Map.null depOnlyConstraints) -> do-            logInfo $ "Retrying with " <> RIO.display srcNames <> " as preferences..."-            solver Preference-        _ -> return eresult--    case eresult' of-        Right deps -> do-            let-                -- All src package constraints returned by cabal.-                -- Flags may have changed.-                srcs = Map.intersection deps srcConstraints-                inSnap = Map.intersection deps snapConstraints-                -- All packages which are in the snapshot but cabal solver-                -- returned versions or flags different from the snapshot.-                inSnapChanged = Map.differenceWith diffConstraints-                                                   inSnap snapConstraints--                           -- If a package appears in both the-                           -- snapshot and locally, we don't want to-                           -- include it in extra-deps. This makes-                           -- sure we filter out such packages. See:-                           -- https://github.com/commercialhaskell/stack/issues/3533--                                    `Map.difference` srcConstraints--                -- Packages neither in snapshot, nor srcs-                extra = Map.difference deps (Map.union srcConstraints-                                                       snapConstraints)-                external = Map.union inSnapChanged extra--            -- Just in case.-            -- If cabal output contains versions of user packages, those-            -- versions better be the same as those in our cabal file i.e.-            -- cabal should not be solving using versions from external-            -- indices.-            let outVers  = fmap fst srcs-                inVers   = fmap fst srcConstraints-                bothVers = Map.intersectionWith (\v1 v2 -> (v1, v2))-                                                inVers outVers-            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))--            logInfo $ "Successfully determined a build plan with "-                     <> displayShow (Map.size external)-                     <> " external dependencies."--            return $ Right (srcs, external)-        Left x -> do-            logInfo "*** Failed to arrive at a workable build plan."-            return $ Left x-    where-        -- Think of the first map as the deps reported in cabal output and-        -- the second as the snapshot packages--        -- Note: For flags we only require that the flags in cabal output be a-        -- subset of the snapshot flags. This is to avoid a false difference-        -- reporting due to any spurious flags in the build plan which will-        -- always be absent in the cabal output.-        diffConstraints-            :: (Eq v, Eq a, Ord k)-            => (v, Map k a) -> (v, Map k a) -> Maybe (v, Map k a)-        diffConstraints (v, f) (v', f')-            | (v == v') && (f `Map.isSubmapOf` f') = Nothing-            | otherwise              = Just (v, f)---- | Given a resolver (snpashot, compiler or custom resolver)--- return the compiler version, package versions and packages flags--- for that resolver.-getResolverConstraints-    :: (HasConfig env, HasGHCVariant env)-    => Maybe (CompilerVersion 'CVActual) -- ^ actually installed compiler-    -> Path Abs File-    -> SnapshotDef-    -> RIO env-         (CompilerVersion 'CVActual,-          Map PackageName (Version, Map FlagName Bool))-getResolverConstraints mcompilerVersion stackYaml sd = do-    ls <- loadSnapshot mcompilerVersion (parent stackYaml) sd-    return (lsCompilerVersion ls, lsConstraints ls)-  where-    lpiConstraints lpi = (lpiVersion lpi, lpiFlags lpi)-    lsConstraints ls = Map.union-      (Map.map lpiConstraints (lsPackages ls))-      (Map.map lpiConstraints (lsGlobals ls))---- | Finds all directories with a .cabal file or an hpack--- package.yaml.  Subdirectories can be included depending on the--- @recurse@ parameter.-findCabalDirs-  :: HasConfig env-  => Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir))-findCabalDirs recurse dir =-    Set.fromList . map parent-    <$> liftIO (findFiles dir isHpackOrCabal subdirFilter)-  where-    subdirFilter subdir = recurse && not (isIgnored subdir)-    isHpack = (== "package.yaml")     . toFilePath . filename-    isCabal = (".cabal" `isSuffixOf`) . toFilePath-    isHpackOrCabal x = isHpack x || isCabal x--    isIgnored path = "." `isPrefixOf` dirName || dirName `Set.member` ignoredDirs-      where-        dirName = FP.dropTrailingPathSeparator (toFilePath (dirname path))---- | Special directories that we don't want to traverse for .cabal files-ignoredDirs :: Set FilePath-ignoredDirs = Set.fromList-    [ "dist"-    ]---- | Perform some basic checks on a list of cabal files to be used for creating--- stack config. It checks for duplicate package names, package name and--- cabal file name mismatch and reports any issues related to those.------ If no error occurs it returns filepath and @GenericPackageDescription@s--- pairs as well as any filenames for duplicate packages not included in the--- pairs.-cabalPackagesCheck-    :: (HasConfig env, HasGHCVariant env)-     => [Path Abs Dir]-     -> String-     -> Maybe String-     -> RIO env-          ( Map PackageName (Path Abs File, C.GenericPackageDescription)-          , [Path Abs File])-cabalPackagesCheck cabaldirs noPkgMsg dupErrMsg = do-    when (null cabaldirs) $-        error noPkgMsg--    relpaths <- mapM prettyPath cabaldirs-    logInfo "Using cabal packages:"-    logInfo $ formatGroup relpaths--    packages <- map (\(x, y) -> (y, x)) <$>-                mapM (flip readPackageUnresolvedDir True)-                cabaldirs--    -- package name cannot be empty or missing otherwise-    -- it will result in cabal solver failure.-    -- stack requires packages name to match the cabal file name-    -- Just the latter check is enough to cover both the cases--    let normalizeString = T.unpack . T.normalize T.NFC . T.pack-        getNameMismatchPkg (fp, gpd)-            | (normalizeString . show . gpdPackageName) gpd /= (normalizeString . FP.takeBaseName . toFilePath) fp-                = Just fp-            | otherwise = Nothing-        nameMismatchPkgs = mapMaybe getNameMismatchPkg packages--    when (nameMismatchPkgs /= []) $ do-        rels <- mapM prettyPath nameMismatchPkgs-        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"-                <> T.unpack (utf8BuilderToText (formatGroup rels))--    let dupGroups = filter ((> 1) . length)-                            . groupSortOn (gpdPackageName . snd)-        dupAll    = concat $ dupGroups packages--        -- Among duplicates prefer to include the ones in upper level dirs-        pathlen     = length . FP.splitPath . toFilePath . fst-        getmin      = minimumBy (compare `on` pathlen)-        dupSelected = map getmin (dupGroups packages)-        dupIgnored  = dupAll \\ dupSelected-        unique      = packages \\ dupIgnored--    when (dupIgnored /= []) $ do-        dups <- mapM (mapM (prettyPath. fst)) (dupGroups packages)-        logWarn $-            "Following packages have duplicate package names:\n" <>-            mconcat (intersperse "\n" (map formatGroup dups))-        case dupErrMsg of-          Nothing -> logWarn $-                 "Packages with duplicate names will be ignored.\n"-              <> "Packages in upper level directories will be preferred.\n"-          Just msg -> error msg--    return (Map.fromList-            $ map (\(file, gpd) -> (gpdPackageName gpd,(file, gpd))) unique-           , map fst dupIgnored)--formatGroup :: [String] -> Utf8Builder-formatGroup = foldMap (\path -> "- " <> fromString path <> "\n")--reportMissingCabalFiles-  :: HasConfig env-  => [Path Abs File]   -- ^ Directories to scan-  -> Bool              -- ^ Whether to scan sub-directories-  -> RIO env ()-reportMissingCabalFiles cabalfps includeSubdirs = do-    allCabalDirs <- findCabalDirs includeSubdirs =<< getCurrentDir--    relpaths <- mapM prettyPath-              $ Set.toList-              $ allCabalDirs `Set.difference` Set.fromList (map parent cabalfps)-    unless (null relpaths) $ do-        logWarn "The following packages are missing from the config:"-        logWarn $ formatGroup relpaths---- TODO Currently solver uses a stack.yaml in the parent chain when there is--- no stack.yaml in the current directory. It should instead look for a--- stack yaml only in the current directory and suggest init if there is--- none available. That will make the behavior consistent with init and provide--- a correct meaning to a --ignore-subdirs option if implemented.---- | Verify the combination of resolver, package flags and extra--- dependencies in an existing stack.yaml and suggest changes in flags or--- extra dependencies so that the specified packages can be compiled.-solveExtraDeps-    :: HasEnvConfig env-    => Bool -- ^ modify stack.yaml?-    -> RIO env ()-solveExtraDeps modStackYaml = do-    bconfig <- view buildConfigL--    let stackYaml = bcStackYaml bconfig-    relStackYaml <- prettyPath stackYaml--    logInfo $ "Using configuration file: " <> fromString relStackYaml-    lp <- getLocalPackages-    let packages = lpProject lp-    let 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 \-                   \generate the config file."-        dupPkgFooter = "Please remove the directories containing duplicate \-                       \entries from '" <> relStackYaml <> "'."--        cabalDirs = map lpvRoot    $ Map.elems packages-        cabalfps  = map lpvCabalFP $ Map.elems packages-    -- TODO when solver supports --ignore-subdirs option pass that as the-    -- second argument here.-    reportMissingCabalFiles cabalfps True-    (bundle, _) <- cabalPackagesCheck cabalDirs noPkgMsg (Just dupPkgFooter)--    let gpds              = Map.elems $ fmap snd bundle-        oldFlags          = bcFlags bconfig-        oldExtraVersions  = Map.map (gpdVersion . fst) (lpDependencies lp)-        sd                = bcSnapshotDef bconfig-        resolver          = sdResolver sd-        oldSrcs           = gpdPackages gpds-        oldSrcFlags       = Map.intersection oldFlags oldSrcs-        oldExtraFlags     = Map.intersection oldFlags oldExtraVersions--        srcConstraints    = mergeConstraints oldSrcs oldSrcFlags-        extraConstraints  = mergeConstraints oldExtraVersions oldExtraFlags--    resolverResult <- checkSnapBuildPlanActual (parent stackYaml) gpds (Just oldSrcFlags) sd-    resultSpecs <- case resolverResult of-        BuildPlanCheckOk flags ->-            return $ Just (mergeConstraints oldSrcs flags, Map.empty)-        BuildPlanCheckPartial {} ->-            either (const Nothing) Just <$>-            solveResolverSpec stackYaml cabalDirs-                              (sd, srcConstraints, extraConstraints)-            -- TODO Solver should also use the init code to ignore incompatible-            -- packages-        BuildPlanCheckFail {} ->-            throwM $ ResolverMismatch IsSolverCmd (sdResolverName sd) (show resolverResult)--    (srcs, edeps) <- case resultSpecs of-        Nothing -> throwM (SolverGiveUp giveUpMsg)-        Just x -> return x--    mOldResolver <- view $ configL.to (fmap (projectResolver . fst) . configMaybeProject)--    let-        flags = removeSrcPkgDefaultFlags gpds (fmap snd (Map.union srcs edeps))-        versions = fmap fst edeps--        vDiff v v' = if v == v' then Nothing else Just v-        versionsDiff = Map.differenceWith vDiff-        newVersions  = versionsDiff versions oldExtraVersions-        goneVersions = versionsDiff oldExtraVersions versions--        fDiff f f' = if f == f' then Nothing else Just f-        flagsDiff  = Map.differenceWith fDiff-        newFlags   = flagsDiff flags oldFlags-        goneFlags  = flagsDiff oldFlags flags--        changed =    any (not . Map.null) [newVersions, goneVersions]-                  || any (not . Map.null) [newFlags, goneFlags]-                  || any (/= void resolver) (fmap void mOldResolver)--    if changed then do-        logInfo ""-        logInfo $ "The following changes will be made to "-                   <> fromString relStackYaml <> ":"--        printResolver (fmap void mOldResolver) (void resolver)--        printFlags newFlags  "* Flags to be added"-        printDeps  newVersions   "* Dependencies to be added"--        printFlags goneFlags "* Flags to be deleted"-        printDeps  goneVersions  "* Dependencies to be deleted"--        -- TODO backup the old config file-        if modStackYaml then do-            writeStackYaml stackYaml resolver versions flags-            logInfo $ "Updated " <> fromString relStackYaml-        else do-            logInfo $ "To automatically update " <> fromString relStackYaml-                       <> ", rerun with '--update-config'"-     else-        logInfo $ "No changes needed to " <> fromString relStackYaml--    where-        indentLines t = T.unlines $ fmap ("    " <>) (T.lines t)--        printResolver mOldRes res = do-            forM_ mOldRes $ \oldRes ->-                when (res /= oldRes) $ do-                    logInfo $-                        "* Resolver changes from " <>-                        RIO.display (resolverRawName oldRes) <>-                        " to " <>-                        RIO.display (resolverRawName res)--        printFlags fl msg = do-            unless (Map.null fl) $ do-                logInfo $ fromString msg-                logInfo $ RIO.display $ indentLines $ decodeUtf8 $ Yaml.encode-                                       $ object ["flags" .= fl]--        printDeps deps msg = do-            unless (Map.null deps) $ do-                logInfo $ fromString msg-                logInfo $ RIO.display $ indentLines $ decodeUtf8 $ Yaml.encode $ object-                        ["extra-deps" .= map fromTuple (Map.toList deps)]--        writeStackYaml path res deps fl = do-            let fp = toFilePath path-            obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return-            -- Check input file and show warnings-            _ <- loadConfigYaml (parseProjectAndConfigMonoid (parent path)) path-            let obj' =-                    HashMap.insert "extra-deps"-                        (toJSON $ map fromTuple $ Map.toList deps)-                  $ HashMap.insert ("flags" :: Text) (toJSON fl)-                  $ HashMap.insert ("resolver" :: Text) (toJSON res) obj-            liftIO $ Yaml.encodeFile fp obj'--        giveUpMsg = concat-            [ "    - Update external packages with 'stack update' and try again.\n"-            , "    - Tweak " <> toFilePath stackDotYaml <> " and try again\n"-            , "        - Remove any unnecessary packages.\n"-            , "        - Add any missing remote packages.\n"-            , "        - Add extra dependencies to guide solver.\n"-            , "        - Adjust resolver.\n"-            ]---- | Same as 'checkSnapBuildPLan', but set up a real GHC if needed.------ If we're using a Stackage snapshot, we can use the snapshot hints--- to determine global library information. This will not be available--- for custom and GHC resolvers, however. Therefore, we insist that it--- be installed first. Fortunately, the standard `stack solver`--- behavior only chooses Stackage snapshots, so the common case will--- not force the installation of a bunch of GHC versions.-checkSnapBuildPlanActual-    :: (HasConfig env, HasGHCVariant env)-    => Path Abs Dir -- ^ project root, used for checking out necessary files-    -> [C.GenericPackageDescription]-    -> Maybe (Map PackageName (Map FlagName Bool))-    -> SnapshotDef-    -> RIO env BuildPlanCheck-checkSnapBuildPlanActual root gpds flags sd = do-    let forNonSnapshot inner = setupCabalEnv (sdWantedCompilerVersion sd) (inner . Just)-        runner =-          case sdResolver sd of-            ResolverStackage _ -> ($ Nothing)-            ResolverCompiler _ -> forNonSnapshot-            ResolverCustom _ _ -> forNonSnapshot--    runner $ checkSnapBuildPlan root gpds flags sd--prettyPath-    :: forall r t m. (MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t))-    => Path r t -> m String-prettyPath path = do-    eres <- liftIO $ try $ makeRelativeToCurrentDir path-    return $ case eres of-        Left (_ :: PathException) -> toFilePath path-        Right res -> toFilePath (res :: Path Rel t)
+ src/Stack/SourceMap.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+module Stack.SourceMap+    ( mkProjectPackage+    , snapToDepPackage+    , additionalDepPackage+    , loadVersion+    , getPLIVersion+    , loadGlobalHints+    , DumpedGlobalPackage+    , actualFromGhc+    , actualFromHints+    , checkFlagsUsedThrowing+    , globalCondCheck+    , pruneGlobals+    , globalsFromHints+    , getCompilerInfo+    , immutableLocSha+    , loadProjectSnapshotCandidate+    , SnapshotCandidate+    , globalsFromDump+    ) where++import Data.ByteString.Builder (byteString)+import qualified Data.Conduit.List as CL+import qualified Distribution.PackageDescription as PD+import Distribution.System (Platform(..))+import Pantry+import qualified Pantry.SHA256 as SHA256+import qualified RIO+import qualified RIO.Map as Map+import qualified RIO.Set as Set+import RIO.Process+import Stack.PackageDump+import Stack.Prelude+import Stack.Types.Build+import Stack.Types.Compiler+import Stack.Types.Config+import Stack.Types.SourceMap++-- | Create a 'ProjectPackage' from a directory containing a package.+mkProjectPackage ::+       forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)+    => PrintWarnings+    -> ResolvedPath Dir+    -> Bool+    -> RIO env ProjectPackage+mkProjectPackage printWarnings dir buildHaddocks = do+   (gpd, name, cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)+   return ProjectPackage+     { ppCabalFP = cabalfp+     , ppResolvedDir = dir+     , ppCommon = CommonPackage+                  { cpGPD = gpd printWarnings+                  , cpName = name+                  , cpFlags = mempty+                  , cpGhcOptions = mempty+                  , cpCabalConfigOpts = mempty+                  , cpHaddocks = buildHaddocks+                  }+     }++-- | Create a 'DepPackage' from a 'PackageLocation', from some additional+-- to a snapshot setting (extra-deps or command line)+additionalDepPackage+  :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)+  => Bool+  -> PackageLocation+  -> RIO env DepPackage+additionalDepPackage buildHaddocks pl = do+  (name, gpdio) <-+    case pl of+      PLMutable dir -> do+        (gpdio, name, _cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)+        pure (name, gpdio NoPrintWarnings)+      PLImmutable pli -> do+        let PackageIdentifier name _ = packageLocationIdent pli+        run <- askRunInIO+        pure (name, run $ loadCabalFileImmutable pli)+  return DepPackage+    { dpLocation = pl+    , dpHidden = False+    , dpFromSnapshot = NotFromSnapshot+    , dpCommon = CommonPackage+                  { cpGPD = gpdio+                  , cpName = name+                  , cpFlags = mempty+                  , cpGhcOptions = mempty+                  , cpCabalConfigOpts = mempty+                  , cpHaddocks = buildHaddocks+                  }+    }++snapToDepPackage ::+       forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)+    => Bool+    -> PackageName+    -> SnapshotPackage+    -> RIO env DepPackage+snapToDepPackage buildHaddocks name SnapshotPackage{..} = do+  run <- askRunInIO+  return DepPackage+    { dpLocation = PLImmutable spLocation+    , dpHidden = spHidden+    , dpFromSnapshot = FromSnapshot+    , dpCommon = CommonPackage+                  { cpGPD = run $ loadCabalFileImmutable spLocation+                  , cpName = name+                  , cpFlags = spFlags+                  , cpGhcOptions = spGhcOptions+                  , cpCabalConfigOpts = [] -- No spCabalConfigOpts, not present in snapshots+                  , cpHaddocks = buildHaddocks+                  }+    }++loadVersion :: MonadIO m => CommonPackage -> m Version+loadVersion common = do+    gpd <- liftIO $ cpGPD common+    return (pkgVersion $ PD.package $ PD.packageDescription gpd)++getPLIVersion :: PackageLocationImmutable -> Version+getPLIVersion (PLIHackage (PackageIdentifier _ v) _ _) = v+getPLIVersion (PLIArchive _ pm) = pkgVersion $ pmIdent pm+getPLIVersion (PLIRepo _ pm) = pkgVersion $ pmIdent pm++globalsFromDump ::+       (HasLogFunc env, HasProcessContext env)+    => GhcPkgExe+    -> RIO env (Map PackageName DumpedGlobalPackage)+globalsFromDump pkgexe = do+    let pkgConduit =+            conduitDumpPackage .|+            CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp)+        toGlobals ds =+          Map.fromList $ map (pkgName . dpPackageIdent &&& id) $ Map.elems ds+    toGlobals <$> ghcPkgDump pkgexe [] pkgConduit++globalsFromHints ::+       HasConfig env+    => WantedCompiler+    -> RIO env (Map PackageName Version)+globalsFromHints compiler = do+    mglobalHints <- loadGlobalHints compiler+    case mglobalHints of+        Just hints -> pure hints+        Nothing -> do+            logWarn $ "Unable to load global hints for " <> RIO.display compiler+            pure mempty++type DumpedGlobalPackage = DumpPackage++actualFromGhc ::+       (HasConfig env, HasCompiler env)+    => SMWanted+    -> ActualCompiler+    -> RIO env (SMActual DumpedGlobalPackage)+actualFromGhc smw ac = do+    globals <- view $ compilerPathsL.to cpGlobalDump+    return+        SMActual+        { smaCompiler = ac+        , smaProject = smwProject smw+        , smaDeps = smwDeps smw+        , smaGlobal = globals+        }++actualFromHints ::+       (HasConfig env)+    => SMWanted+    -> ActualCompiler+    -> RIO env (SMActual GlobalPackageVersion)+actualFromHints smw ac = do+    globals <- globalsFromHints (actualToWanted ac)+    return+        SMActual+        { smaCompiler = ac+        , smaProject = smwProject smw+        , smaDeps = smwDeps smw+        , smaGlobal = Map.map GlobalPackageVersion globals+        }++-- | Simple cond check for boot packages - checks only OS and Arch+globalCondCheck :: (HasConfig env) => RIO env (PD.ConfVar -> Either PD.ConfVar Bool)+globalCondCheck = do+  Platform arch os <- view platformL+  let condCheck (PD.OS os') = pure $ os' == os+      condCheck (PD.Arch arch') = pure $ arch' == arch+      condCheck c = Left c+  return condCheck++checkFlagsUsedThrowing ::+       (MonadIO m, MonadThrow m)+    => Map PackageName (Map FlagName Bool)+    -> FlagSource+    -> Map PackageName ProjectPackage+    -> Map PackageName DepPackage+    -> m ()+checkFlagsUsedThrowing packageFlags source prjPackages deps = do+    unusedFlags <-+        forMaybeM (Map.toList packageFlags) $ \(pname, flags) ->+            getUnusedPackageFlags (pname, flags) source prjPackages deps+    unless (null unusedFlags) $+        throwM $ InvalidFlagSpecification $ Set.fromList unusedFlags++getUnusedPackageFlags ::+       MonadIO m+    => (PackageName, Map FlagName Bool)+    -> FlagSource+    -> Map PackageName ProjectPackage+    -> Map PackageName DepPackage+    -> m (Maybe UnusedFlags)+getUnusedPackageFlags (name, userFlags) source prj deps =+    let maybeCommon =+          fmap ppCommon (Map.lookup name prj) <|>+          fmap dpCommon (Map.lookup name deps)+    in case maybeCommon  of+        -- Package is not available as project or dependency+        Nothing ->+            pure $ Just $ UFNoPackage source name+        -- Package exists, let's check if the flags are defined+        Just common -> do+            gpd <- liftIO $ cpGPD common+            let pname = pkgName $ PD.package $ PD.packageDescription gpd+                pkgFlags = Set.fromList $ map PD.flagName $ PD.genPackageFlags gpd+                unused = Map.keysSet $ Map.withoutKeys userFlags pkgFlags+            if Set.null unused+                    -- All flags are defined, nothing to do+                    then pure Nothing+                    -- Error about the undefined flags+                    else pure $ Just $ UFFlagsNotDefined source pname pkgFlags unused++pruneGlobals ::+       Map PackageName DumpedGlobalPackage+    -> Set PackageName+    -> Map PackageName GlobalPackage+pruneGlobals globals deps =+  let (prunedGlobals, keptGlobals) =+        partitionReplacedDependencies globals (pkgName . dpPackageIdent)+            dpGhcPkgId dpDepends deps+  in Map.map (GlobalPackage . pkgVersion . dpPackageIdent) keptGlobals <>+     Map.map ReplacedGlobalPackage prunedGlobals++getCompilerInfo :: (HasConfig env, HasCompiler env) => RIO env Builder+getCompilerInfo = view $ compilerPathsL.to (byteString . cpGhcInfo)++immutableLocSha :: PackageLocationImmutable -> Builder+immutableLocSha = byteString . treeKeyToBs . locationTreeKey+  where+    locationTreeKey (PLIHackage _ _ tk) = tk+    locationTreeKey (PLIArchive _ pm) = pmTreeKey pm+    locationTreeKey (PLIRepo _ pm) = pmTreeKey pm+    treeKeyToBs (TreeKey (BlobKey sha _)) = SHA256.toHexBytes sha++type SnapshotCandidate env+     = [ResolvedPath Dir] -> RIO env (SMActual GlobalPackageVersion)++loadProjectSnapshotCandidate ::+       (HasConfig env)+    => RawSnapshotLocation+    -> PrintWarnings+    -> Bool+    -> RIO env (SnapshotCandidate env)+loadProjectSnapshotCandidate loc printWarnings buildHaddocks = do+    (snapshot, _, _) <- loadAndCompleteSnapshotRaw loc Map.empty Map.empty+    deps <- Map.traverseWithKey (snapToDepPackage False) (snapshotPackages snapshot)+    let wc = snapshotCompiler snapshot+    globals <- Map.map GlobalPackageVersion <$> globalsFromHints wc+    return $ \projectPackages -> do+        prjPkgs <- fmap Map.fromList . for projectPackages $ \resolved -> do+            pp <- mkProjectPackage printWarnings resolved buildHaddocks+            pure (cpName $ ppCommon pp, pp)+        return SMActual+              { smaCompiler = wantedToActual $ snapshotCompiler snapshot+              , smaProject = prjPkgs+              , smaDeps = Map.difference deps prjPkgs+              , smaGlobal = globals+              }
− src/Stack/StaticBytes.hs 
@@ -1,234 +0,0 @@--- This module can (and perhaps should) be separate into its own--- package, it's generally useful.-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NoImplicitPrelude #-}-module Stack.StaticBytes-  ( Bytes8-  , Bytes16-  , Bytes32-  , Bytes64-  , Bytes128-  , DynamicBytes-  , StaticBytes-  , StaticBytesException (..)-  , toStaticExact-  , toStaticPad-  , toStaticTruncate-  , toStaticPadTruncate-  , fromStatic-  ) where--import Stack.Prelude hiding (words)-import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as B-import qualified Data.Vector.Primitive as VP-import qualified Data.Vector.Unboxed as VU-import qualified Data.Vector.Unboxed.Base as VU-import qualified Data.Vector.Storable as VS-import System.IO.Unsafe (unsafePerformIO)-import Foreign.Ptr-import Foreign.ForeignPtr-import Foreign.Storable-import Data.Bits-import qualified Data.Primitive.ByteArray as BA-import Data.ByteArray--newtype Bytes8 = Bytes8 Word64-  deriving (Eq, Ord, Generic, NFData, Hashable, Data, Store)-instance Show Bytes8 where -- FIXME good enough?-  show (Bytes8 w) = show (fromWordsD 8 [w] :: B.ByteString)-data Bytes16 = Bytes16 !Bytes8 !Bytes8-  deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data, Store)-data Bytes32 = Bytes32 !Bytes16 !Bytes16-  deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data, Store)-data Bytes64 = Bytes64 !Bytes32 !Bytes32-  deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data, Store)-data Bytes128 = Bytes128 !Bytes64 !Bytes64-  deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data, Store)--data StaticBytesException-  = NotEnoughBytes-  | TooManyBytes-  deriving (Show, Eq, Typeable)-instance Exception StaticBytesException---- All lengths below are given in bytes--class DynamicBytes dbytes where-  lengthD :: dbytes -> Int-  -- | Yeah, it looks terrible to use a list here, but fusion should-  -- kick in-  withPeekD :: dbytes -> ((Int -> IO Word64) -> IO a) -> IO a-  -- | May throw a runtime exception if invariants are violated!-  fromWordsD :: Int -> [Word64] -> dbytes--fromWordsForeign-  :: (ForeignPtr a -> Int -> b)-  -> Int-  -> [Word64]-  -> b-fromWordsForeign wrapper len words0 = unsafePerformIO $ do-  fptr <- B.mallocByteString len-  withForeignPtr fptr $ \ptr -> do-    let loop _ [] = return ()-        loop off (w:ws) = do-          pokeElemOff (castPtr ptr) off w-          loop (off + 1) ws-    loop 0 words0-  return $ wrapper fptr len--withPeekForeign-  :: (ForeignPtr a, Int, Int)-  -> ((Int -> IO Word64) -> IO b)-  -> IO b-withPeekForeign (fptr, off, len) inner =-  withForeignPtr fptr $ \ptr -> do-    let f off'-          | off' >= len = return 0-          | off' + 8 > len = do-              let loop w64 i-                    | off' + i >= len = return w64-                    | otherwise = do-                        w8 :: Word8 <- peekByteOff ptr (off + off' + i)-                        let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64-                        loop w64' (i + 1)-              loop 0 0-          | otherwise = peekByteOff ptr (off + off')-    inner f--instance DynamicBytes B.ByteString where-  lengthD = B.length-  fromWordsD = fromWordsForeign (\fptr len -> B.fromForeignPtr fptr 0 len)-  withPeekD = withPeekForeign . B.toForeignPtr--instance word8 ~ Word8 => DynamicBytes (VS.Vector word8) where-  lengthD = VS.length-  fromWordsD = fromWordsForeign VS.unsafeFromForeignPtr0-  withPeekD = withPeekForeign . VS.unsafeToForeignPtr--instance word8 ~ Word8 => DynamicBytes (VP.Vector word8) where-  lengthD = VP.length-  fromWordsD len words0 = unsafePerformIO $ do-    ba <- BA.newByteArray len-    let loop _ [] =-          VP.Vector 0 len <$> BA.unsafeFreezeByteArray ba-        loop i (w:ws) = do-          BA.writeByteArray ba i w-          loop (i + 1) ws-    loop 0 words0-  withPeekD (VP.Vector off len ba) inner = do-    let f off'-          | off' >= len = return 0-          | off' + 8 > len = do-              let loop w64 i-                    | off' + i >= len = return w64-                    | otherwise = do-                        let w8 :: Word8 = BA.indexByteArray ba (off + off' + i)-                        let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64-                        loop w64' (i + 1)-              loop 0 0-          | otherwise = return $ BA.indexByteArray ba (off + (off' `div` 8))-    inner f--instance word8 ~ Word8 => DynamicBytes (VU.Vector word8) where-  lengthD = VU.length-  fromWordsD len words = VU.V_Word8 (fromWordsD len words)-  withPeekD (VU.V_Word8 v) = withPeekD v--class StaticBytes sbytes where-  lengthS :: proxy sbytes -> Int -- use type level literals instead?-  -- difference list-  toWordsS :: sbytes -> [Word64] -> [Word64]-  usePeekS :: Int -> (Int -> IO Word64) -> IO sbytes--instance StaticBytes Bytes8 where-  lengthS _ = 8-  toWordsS (Bytes8 w) = (w:)-  usePeekS off f = Bytes8 <$> f off--instance StaticBytes Bytes16 where-  lengthS _ = 16-  toWordsS (Bytes16 b1 b2) = toWordsS b1 . toWordsS b2-  usePeekS off f = Bytes16 <$> usePeekS off f <*> usePeekS (off + 8) f--instance StaticBytes Bytes32 where-  lengthS _ = 32-  toWordsS (Bytes32 b1 b2) = toWordsS b1 . toWordsS b2-  usePeekS off f = Bytes32 <$> usePeekS off f <*> usePeekS (off + 16) f--instance StaticBytes Bytes64 where-  lengthS _ = 64-  toWordsS (Bytes64 b1 b2) = toWordsS b1 . toWordsS b2-  usePeekS off f = Bytes64 <$> usePeekS off f <*> usePeekS (off + 32) f--instance StaticBytes Bytes128 where-  lengthS _ = 128-  toWordsS (Bytes128 b1 b2) = toWordsS b1 . toWordsS b2-  usePeekS off f = Bytes128 <$> usePeekS off f <*> usePeekS (off + 64) f--instance ByteArrayAccess Bytes8 where-  length _ = 8-  withByteArray = withByteArrayS-instance ByteArrayAccess Bytes16 where-  length _ = 16-  withByteArray = withByteArrayS-instance ByteArrayAccess Bytes32 where-  length _ = 32-  withByteArray = withByteArrayS-instance ByteArrayAccess Bytes64 where-  length _ = 64-  withByteArray = withByteArrayS-instance ByteArrayAccess Bytes128 where-  length _ = 128-  withByteArray = withByteArrayS--withByteArrayS :: StaticBytes sbytes => sbytes -> (Ptr p -> IO a) -> IO a-withByteArrayS sbytes = withByteArray (fromStatic sbytes :: ByteString)--toStaticExact-  :: forall dbytes sbytes.-     (DynamicBytes dbytes, StaticBytes sbytes)-  => dbytes-  -> Either StaticBytesException sbytes-toStaticExact dbytes =-  case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of-    LT -> Left NotEnoughBytes-    GT -> Left TooManyBytes-    EQ -> Right (toStaticPadTruncate dbytes)--toStaticPad-  :: forall dbytes sbytes.-     (DynamicBytes dbytes, StaticBytes sbytes)-  => dbytes-  -> Either StaticBytesException sbytes-toStaticPad dbytes =-  case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of-    GT -> Left TooManyBytes-    _  -> Right (toStaticPadTruncate dbytes)--toStaticTruncate-  :: forall dbytes sbytes.-     (DynamicBytes dbytes, StaticBytes sbytes)-  => dbytes-  -> Either StaticBytesException sbytes-toStaticTruncate dbytes =-  case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of-    LT -> Left NotEnoughBytes-    _  -> Right (toStaticPadTruncate dbytes)--toStaticPadTruncate-  :: (DynamicBytes dbytes, StaticBytes sbytes)-  => dbytes-  -> sbytes-toStaticPadTruncate dbytes = unsafePerformIO (withPeekD dbytes (usePeekS 0))--fromStatic-  :: forall dbytes sbytes.-     (DynamicBytes dbytes, StaticBytes sbytes)-  => sbytes-  -> dbytes-fromStatic = fromWordsD (lengthS (Nothing :: Maybe sbytes)) . ($ []) . toWordsS
+ src/Stack/Storage.hs view
@@ -0,0 +1,570 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unused-top-binds -Wno-identities #-}++-- | Work with SQLite database used for caches.+module Stack.Storage+    ( initStorage+    , withStorage+    , ConfigCacheKey+    , configCacheKey+    , loadConfigCache+    , saveConfigCache+    , deactiveConfigCache+    , PrecompiledCacheKey+    , precompiledCacheKey+    , loadPrecompiledCache+    , savePrecompiledCache+    , loadDockerImageExeCache+    , saveDockerImageExeCache+    , loadCompilerPaths+    , saveCompilerPaths+    , upgradeChecksSince+    , logUpgradeCheck+    ) where++import qualified Data.ByteString as S+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Time.Clock (UTCTime)+import Database.Persist.Sql (SqlBackend)+import Database.Persist.Sqlite+import Database.Persist.TH+import Distribution.Text (simpleParse, display)+import Foreign.C.Types (CTime (..))+import qualified Pantry.Internal as SQLite+import Path+import Path.IO (resolveFile', resolveDir')+import qualified RIO.FilePath as FP+import Stack.Prelude hiding (MigrationFailure)+import Stack.Types.Build+import Stack.Types.Cache+import Stack.Types.Compiler+import Stack.Types.CompilerBuild (CompilerBuild)+import Stack.Types.Config (HasConfig, configL, configStorage, CompilerPaths (..), GhcPkgExe (..))+import Stack.Types.GhcPkgId+import System.Posix.Types (COff (..))+import System.PosixCompat.Files (getFileStatus, fileSize, modificationTime)++share [ mkPersist sqlSettings+      , mkDeleteCascade sqlSettings+      , mkMigrate "migrateAll"+    ]+    [persistLowerCase|+ConfigCacheParent sql="config_cache"+  directory FilePath "default=(hex(randomblob(16)))"+  type ConfigCacheType+  pkgSrc CachePkgSrc+  active Bool+  pathEnvVar Text+  haddock Bool default=0+  UniqueConfigCacheParent directory type sql="unique_config_cache"+  deriving Show++ConfigCacheDirOption+  parent ConfigCacheParentId sql="config_cache_id"+  index Int+  value String sql="option"+  UniqueConfigCacheDirOption parent index+  deriving Show++ConfigCacheNoDirOption+  parent ConfigCacheParentId sql="config_cache_id"+  index Int+  value String sql="option"+  UniqueConfigCacheNoDirOption parent index+  deriving Show++ConfigCacheDep+  parent ConfigCacheParentId sql="config_cache_id"+  value GhcPkgId sql="ghc_pkg_id"+  UniqueConfigCacheDep parent value+  deriving Show++ConfigCacheComponent+  parent ConfigCacheParentId sql="config_cache_id"+  value S.ByteString sql="component"+  UniqueConfigCacheComponent parent value+  deriving Show++PrecompiledCacheParent sql="precompiled_cache"+  platformGhcDir FilePath "default=(hex(randomblob(16)))"+  compiler Text+  cabalVersion Text+  packageKey Text+  optionsHash ByteString+  haddock Bool default=0+  library FilePath Maybe+  UniquePrecompiledCacheParent platformGhcDir compiler cabalVersion packageKey optionsHash haddock sql="unique_precompiled_cache"+  deriving Show++PrecompiledCacheSubLib+  parent PrecompiledCacheParentId sql="precompiled_cache_id"+  value FilePath sql="sub_lib"+  UniquePrecompiledCacheSubLib parent value+  deriving Show++PrecompiledCacheExe+  parent PrecompiledCacheParentId sql="precompiled_cache_id"+  value FilePath sql="exe"+  UniquePrecompiledCacheExe parent value+  deriving Show++DockerImageExeCache+  imageHash Text+  exePath FilePath+  exeTimestamp UTCTime+  compatible Bool+  DockerImageExeCacheUnique imageHash exePath exeTimestamp+  deriving Show++CompilerCache+  actualVersion ActualCompiler+  arch Text++  -- Include ghc executable size and modified time for sanity checking entries+  ghcPath FilePath+  ghcSize Int64+  ghcModified Int64++  ghcPkgPath FilePath+  runghcPath FilePath+  haddockPath FilePath++  cabalVersion Text+  globalDb FilePath+  globalDbCacheSize Int64+  globalDbCacheModified Int64+  info ByteString++  -- This is the ugliest part of this table, simply storing a Show/Read version of the+  -- data. We could do a better job with normalized data and proper table structure.+  -- However, recomputing this value in the future if the data representation changes+  -- is very cheap, so we'll take the easy way out for now.+  globalDump Text++  UniqueCompilerInfo ghcPath++-- Last time certain actions were performed+LastPerformed+  action Action+  timestamp UTCTime+  UniqueAction action+|]++-- | Initialize the database.+initStorage ::+       HasLogFunc env+    => Path Abs File -- ^ storage file+    -> (SQLite.Storage -> RIO env a)+    -> RIO env a+initStorage = SQLite.initStorage "Stack" migrateAll++-- | Run an action in a database transaction+withStorage ::+       (HasConfig env, HasLogFunc env)+    => ReaderT SqlBackend (RIO env) a+    -> RIO env a+withStorage inner =+    flip SQLite.withStorage_ inner =<< view (configL . to configStorage)++-- | Key used to retrieve configuration or flag cache+type ConfigCacheKey = Unique ConfigCacheParent++-- | Build key used to retrieve configuration or flag cache+configCacheKey :: Path Abs Dir -> ConfigCacheType -> ConfigCacheKey+configCacheKey dir = UniqueConfigCacheParent (toFilePath dir)++-- | Internal helper to read the 'ConfigCache'+readConfigCache ::+       (HasConfig env, HasLogFunc env)+    => Entity ConfigCacheParent+    -> ReaderT SqlBackend (RIO env) ConfigCache+readConfigCache (Entity parentId ConfigCacheParent {..}) = do+    let configCachePkgSrc = configCacheParentPkgSrc+    coDirs <-+        map (configCacheDirOptionValue . entityVal) <$>+        selectList+            [ConfigCacheDirOptionParent ==. parentId]+            [Asc ConfigCacheDirOptionIndex]+    coNoDirs <-+        map (configCacheNoDirOptionValue . entityVal) <$>+        selectList+            [ConfigCacheNoDirOptionParent ==. parentId]+            [Asc ConfigCacheNoDirOptionIndex]+    let configCacheOpts = ConfigureOpts {..}+    configCacheDeps <-+        Set.fromList . map (configCacheDepValue . entityVal) <$>+        selectList [ConfigCacheDepParent ==. parentId] []+    configCacheComponents <-+        Set.fromList . map (configCacheComponentValue . entityVal) <$>+        selectList [ConfigCacheComponentParent ==. parentId] []+    let configCachePathEnvVar = configCacheParentPathEnvVar+    let configCacheHaddock = configCacheParentHaddock+    return ConfigCache {..}++-- | Load 'ConfigCache' from the database.+loadConfigCache ::+       (HasConfig env, HasLogFunc env)+    => ConfigCacheKey+    -> RIO env (Maybe ConfigCache)+loadConfigCache key =+    withStorage $ do+        mparent <- getBy key+        case mparent of+            Nothing -> return Nothing+            Just parentEntity@(Entity _ ConfigCacheParent {..})+                | configCacheParentActive ->+                    Just <$> readConfigCache parentEntity+                | otherwise -> return Nothing++-- | Insert or update 'ConfigCache' to the database.+saveConfigCache ::+       (HasConfig env, HasLogFunc env)+    => ConfigCacheKey+    -> ConfigCache+    -> RIO env ()+saveConfigCache key@(UniqueConfigCacheParent dir type_) new =+    withStorage $ do+        mparent <- getBy key+        (parentId, mold) <-+            case mparent of+                Nothing ->+                    (, Nothing) <$>+                    insert+                        ConfigCacheParent+                            { configCacheParentDirectory = dir+                            , configCacheParentType = type_+                            , configCacheParentPkgSrc = configCachePkgSrc new+                            , configCacheParentActive = True+                            , configCacheParentPathEnvVar = configCachePathEnvVar new+                            , configCacheParentHaddock = configCacheHaddock new+                            }+                Just parentEntity@(Entity parentId _) -> do+                    old <- readConfigCache parentEntity+                    update+                        parentId+                        [ ConfigCacheParentPkgSrc =. configCachePkgSrc new+                        , ConfigCacheParentActive =. True+                        , ConfigCacheParentPathEnvVar =. configCachePathEnvVar new+                        ]+                    return (parentId, Just old)+        updateList+            ConfigCacheDirOption+            ConfigCacheDirOptionParent+            parentId+            ConfigCacheDirOptionIndex+            (maybe [] (coDirs . configCacheOpts) mold)+            (coDirs $ configCacheOpts new)+        updateList+            ConfigCacheNoDirOption+            ConfigCacheNoDirOptionParent+            parentId+            ConfigCacheNoDirOptionIndex+            (maybe [] (coNoDirs . configCacheOpts) mold)+            (coNoDirs $ configCacheOpts new)+        updateSet+            ConfigCacheDep+            ConfigCacheDepParent+            parentId+            ConfigCacheDepValue+            (maybe Set.empty configCacheDeps mold)+            (configCacheDeps new)+        updateSet+            ConfigCacheComponent+            ConfigCacheComponentParent+            parentId+            ConfigCacheComponentValue+            (maybe Set.empty configCacheComponents mold)+            (configCacheComponents new)++-- | Mark 'ConfigCache' as inactive in the database.+-- We use a flag instead of deleting the records since, in most cases, the same+-- cache will be written again within in a few seconds (after+-- `cabal configure`), so this avoids unnecessary database churn.+deactiveConfigCache :: HasConfig env => ConfigCacheKey -> RIO env ()+deactiveConfigCache (UniqueConfigCacheParent dir type_) =+    withStorage $+    updateWhere+        [ConfigCacheParentDirectory ==. dir, ConfigCacheParentType ==. type_]+        [ConfigCacheParentActive =. False]++-- | Key used to retrieve the precompiled cache+type PrecompiledCacheKey = Unique PrecompiledCacheParent++-- | Build key used to retrieve the precompiled cache+precompiledCacheKey ::+       Path Rel Dir+    -> ActualCompiler+    -> Version+    -> Text+    -> ByteString+    -> Bool+    -> PrecompiledCacheKey+precompiledCacheKey platformGhcDir compiler cabalVersion =+    UniquePrecompiledCacheParent+        (toFilePath platformGhcDir)+        (compilerVersionText compiler)+        (T.pack $ versionString cabalVersion)++-- | Internal helper to read the 'PrecompiledCache' from the database+readPrecompiledCache ::+       (HasConfig env, HasLogFunc env)+    => PrecompiledCacheKey+    -> ReaderT SqlBackend (RIO env) (Maybe ( PrecompiledCacheParentId+                                           , PrecompiledCache Rel))+readPrecompiledCache key = do+    mparent <- getBy key+    forM mparent $ \(Entity parentId PrecompiledCacheParent {..}) -> do+        pcLibrary <- mapM parseRelFile precompiledCacheParentLibrary+        pcSubLibs <-+            mapM (parseRelFile . precompiledCacheSubLibValue . entityVal) =<<+            selectList [PrecompiledCacheSubLibParent ==. parentId] []+        pcExes <-+            mapM (parseRelFile . precompiledCacheExeValue . entityVal) =<<+            selectList [PrecompiledCacheExeParent ==. parentId] []+        return (parentId, PrecompiledCache {..})++-- | Load 'PrecompiledCache' from the database.+loadPrecompiledCache ::+       (HasConfig env, HasLogFunc env)+    => PrecompiledCacheKey+    -> RIO env (Maybe (PrecompiledCache Rel))+loadPrecompiledCache key = withStorage $ fmap snd <$> readPrecompiledCache key++-- | Insert or update 'PrecompiledCache' to the database.+savePrecompiledCache ::+       (HasConfig env, HasLogFunc env)+    => PrecompiledCacheKey+    -> PrecompiledCache Rel+    -> RIO env ()+savePrecompiledCache key@(UniquePrecompiledCacheParent precompiledCacheParentPlatformGhcDir precompiledCacheParentCompiler precompiledCacheParentCabalVersion precompiledCacheParentPackageKey precompiledCacheParentOptionsHash precompiledCacheParentHaddock) new =+    withStorage $ do+        let precompiledCacheParentLibrary = fmap toFilePath (pcLibrary new)+        mIdOld <- readPrecompiledCache key+        (parentId, mold) <-+            case mIdOld of+                Nothing -> (, Nothing) <$> insert PrecompiledCacheParent {..}+                Just (parentId, old) -> do+                    update+                        parentId+                        [ PrecompiledCacheParentLibrary =.+                          precompiledCacheParentLibrary+                        ]+                    return (parentId, Just old)+        updateSet+            PrecompiledCacheSubLib+            PrecompiledCacheSubLibParent+            parentId+            PrecompiledCacheSubLibValue+            (maybe Set.empty (toFilePathSet . pcSubLibs) mold)+            (toFilePathSet $ pcSubLibs new)+        updateSet+            PrecompiledCacheExe+            PrecompiledCacheExeParent+            parentId+            PrecompiledCacheExeValue+            (maybe Set.empty (toFilePathSet . pcExes) mold)+            (toFilePathSet $ pcExes new)+  where+    toFilePathSet = Set.fromList . map toFilePath++-- | Get the record of whether an executable is compatible with a Docker image+loadDockerImageExeCache ::+       (HasConfig env, HasLogFunc env)+    => Text+    -> Path Abs File+    -> UTCTime+    -> RIO env (Maybe Bool)+loadDockerImageExeCache imageId exePath exeTimestamp =+    withStorage $+    fmap (dockerImageExeCacheCompatible . entityVal) <$>+    getBy (DockerImageExeCacheUnique imageId (toFilePath exePath) exeTimestamp)++-- | Sest the record of whether an executable is compatible with a Docker image+saveDockerImageExeCache ::+       (HasConfig env, HasLogFunc env)+    => Text+    -> Path Abs File+    -> UTCTime+    -> Bool+    -> RIO env ()+saveDockerImageExeCache imageId exePath exeTimestamp compatible =+    void $+    withStorage $+    upsert+        (DockerImageExeCache+             imageId+             (toFilePath exePath)+             exeTimestamp+             compatible)+        []++-- | Efficiently update a set of values stored in a database table+updateSet ::+       ( PersistEntityBackend record ~ BaseBackend backend+       , PersistField parentid+       , PersistField value+       , Ord value+       , PersistEntity record+       , MonadIO m+       , PersistQueryWrite backend+       )+    => (parentid -> value -> record)+    -> EntityField record parentid+    -> parentid+    -> EntityField record value+    -> Set value+    -> Set value+    -> ReaderT backend m ()+updateSet recordCons parentFieldCons parentId valueFieldCons old new =+    when (old /= new) $ do+        deleteWhere+            [ parentFieldCons ==. parentId+            , valueFieldCons <-. Set.toList (Set.difference old new)+            ]+        insertMany_ $+            map (recordCons parentId) $ Set.toList (Set.difference new old)++-- | Efficiently update a list of values stored in a database table.+updateList ::+       ( PersistEntityBackend record ~ BaseBackend backend+       , PersistField parentid+       , Ord value+       , PersistEntity record+       , MonadIO m+       , PersistQueryWrite backend+       )+    => (parentid -> Int -> value -> record)+    -> EntityField record parentid+    -> parentid+    -> EntityField record Int+    -> [value]+    -> [value]+    -> ReaderT backend m ()+updateList recordCons parentFieldCons parentId indexFieldCons old new =+    when (old /= new) $ do+        let oldSet = Set.fromList (zip [0 ..] old)+            newSet = Set.fromList (zip [0 ..] new)+        deleteWhere+            [ parentFieldCons ==. parentId+            , indexFieldCons <-.+              map fst (Set.toList $ Set.difference oldSet newSet)+            ]+        insertMany_ $+            map (uncurry $ recordCons parentId) $+            Set.toList (Set.difference newSet oldSet)++-- | Type-restricted version of 'fromIntegral' to ensure we're making+-- the value bigger, not smaller.+sizeToInt64 :: COff -> Int64+sizeToInt64 (COff i) = fromIntegral i -- fromIntegral added for 32-bit systems++-- | Type-restricted version of 'fromIntegral' to ensure we're making+-- the value bigger, not smaller.+timeToInt64 :: CTime -> Int64+timeToInt64 (CTime i) = fromIntegral i -- fromIntegral added for 32-bit systems++-- | Load compiler information, if available, and confirm that the+-- referenced files are unchanged. May throw exceptions!+loadCompilerPaths+  :: HasConfig env+  => Path Abs File -- ^ compiler executable+  -> CompilerBuild+  -> Bool -- ^ sandboxed?+  -> RIO env (Maybe CompilerPaths)+loadCompilerPaths compiler build sandboxed = do+  mres <- withStorage $ getBy $ UniqueCompilerInfo $ toFilePath compiler+  for mres $ \(Entity _ CompilerCache {..}) -> do+    compilerStatus <- liftIO $ getFileStatus $ toFilePath compiler+    when+      (compilerCacheGhcSize /= sizeToInt64 (fileSize compilerStatus) ||+       compilerCacheGhcModified /= timeToInt64 (modificationTime compilerStatus))+      (throwString "Compiler file metadata mismatch, ignoring cache")+    globalDbStatus <- liftIO $ getFileStatus $ compilerCacheGlobalDb FP.</> "package.cache"+    when+      (compilerCacheGlobalDbCacheSize /= sizeToInt64 (fileSize globalDbStatus) ||+       compilerCacheGlobalDbCacheModified /= timeToInt64 (modificationTime globalDbStatus))+      (throwString "Global package cache file metadata mismatch, ignoring cache")++    -- We could use parseAbsFile instead of resolveFile' below to+    -- bypass some system calls, at the cost of some really wonky+    -- error messages in case someone screws up their GHC installation+    pkgexe <- resolveFile' compilerCacheGhcPkgPath+    runghc <- resolveFile' compilerCacheRunghcPath+    haddock <- resolveFile' compilerCacheHaddockPath+    globaldb <- resolveDir' compilerCacheGlobalDb++    cabalVersion <- parseVersionThrowing $ T.unpack compilerCacheCabalVersion+    globalDump <-+      case readMaybe $ T.unpack compilerCacheGlobalDump of+        Nothing -> throwString "Global dump did not parse correctly"+        Just globalDump -> pure globalDump+    arch <-+      case simpleParse $ T.unpack compilerCacheArch of+        Nothing -> throwString $ "Invalid arch: " ++ show compilerCacheArch+        Just arch -> pure arch++    pure CompilerPaths+      { cpCompiler = compiler+      , cpCompilerVersion = compilerCacheActualVersion+      , cpArch = arch+      , cpBuild = build+      , cpPkg = GhcPkgExe pkgexe+      , cpInterpreter = runghc+      , cpHaddock = haddock+      , cpSandboxed = sandboxed+      , cpCabalVersion = cabalVersion+      , cpGlobalDB = globaldb+      , cpGhcInfo = compilerCacheInfo+      , cpGlobalDump = globalDump+      }++-- | Save compiler information. May throw exceptions!+saveCompilerPaths+  :: HasConfig env+  => CompilerPaths+  -> RIO env ()+saveCompilerPaths CompilerPaths {..} = withStorage $ do+  deleteBy $ UniqueCompilerInfo $ toFilePath cpCompiler+  compilerStatus <- liftIO $ getFileStatus $ toFilePath cpCompiler+  globalDbStatus <- liftIO $ getFileStatus $ toFilePath $ cpGlobalDB </> $(mkRelFile "package.cache")+  let GhcPkgExe pkgexe = cpPkg+  insert_ CompilerCache+    { compilerCacheActualVersion = cpCompilerVersion+    , compilerCacheGhcPath = toFilePath cpCompiler+    , compilerCacheGhcSize = sizeToInt64 $ fileSize compilerStatus+    , compilerCacheGhcModified = timeToInt64 $ modificationTime compilerStatus+    , compilerCacheGhcPkgPath = toFilePath pkgexe+    , compilerCacheRunghcPath = toFilePath cpInterpreter+    , compilerCacheHaddockPath = toFilePath cpHaddock+    , compilerCacheCabalVersion = T.pack $ versionString cpCabalVersion+    , compilerCacheGlobalDb = toFilePath cpGlobalDB+    , compilerCacheGlobalDbCacheSize = sizeToInt64 $ fileSize globalDbStatus+    , compilerCacheGlobalDbCacheModified = timeToInt64 $ modificationTime globalDbStatus+    , compilerCacheInfo = cpGhcInfo+    , compilerCacheGlobalDump = tshow cpGlobalDump+    , compilerCacheArch = T.pack $ Distribution.Text.display cpArch+    }++-- | How many upgrade checks have occurred since the given timestamp?+upgradeChecksSince :: HasConfig env => UTCTime -> RIO env Int+upgradeChecksSince since = withStorage $ count+  [ LastPerformedAction ==. UpgradeCheck+  , LastPerformedTimestamp >=. since+  ]++-- | Log in the database that an upgrade check occurred at the given time.+logUpgradeCheck :: HasConfig env => UTCTime -> RIO env ()+logUpgradeCheck time = withStorage $ void $ upsert+  (LastPerformed UpgradeCheck time)+  [LastPerformedTimestamp =. time]
src/Stack/Types/Build.hs view
@@ -1,12 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP                        #-} {-# LANGUAGE DataKinds                  #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE TemplateHaskell            #-}  -- | Build-specific types. @@ -15,14 +13,12 @@     ,FlagSource(..)     ,UnusedFlags(..)     ,InstallLocation(..)-    ,ModTime-    ,modTime     ,Installed(..)-    ,piiVersion-    ,piiLocation+    ,psVersion     ,Task(..)     ,taskIsTarget     ,taskLocation+    ,taskTargetIsMutable     ,LocalPackage(..)     ,BaseConfigOpts(..)     ,Plan(..)@@ -33,12 +29,11 @@     ,BuildSubset(..)     ,defaultBuildOpts     ,TaskType(..)-    ,ttPackageLocation+    ,IsMutable(..)+    ,installLocationIsMutable     ,TaskConfigOpts(..)     ,BuildCache(..)-    ,buildCacheVC     ,ConfigCache(..)-    ,configCacheVC     ,configureOpts     ,CachePkgSrc (..)     ,toCachePkgSrc@@ -47,40 +42,37 @@     ,FileCacheInfo (..)     ,ConfigureOpts (..)     ,PrecompiledCache (..)-    ,precompiledCacheVC)+    )     where  import           Stack.Prelude+import           Data.Aeson                      (ToJSON, FromJSON) import qualified Data.ByteString                 as S import           Data.Char                       (isSpace) import           Data.List.Extra import qualified Data.Map                        as Map import qualified Data.Set                        as Set-import           Data.Store.Version-import           Data.Store.VersionTagged import qualified Data.Text                       as T import           Data.Text.Encoding              (decodeUtf8With) import           Data.Text.Encoding.Error        (lenientDecode)-import           Data.Time.Calendar-import           Data.Time.Clock+import           Database.Persist.Sql            (PersistField(..)+                                                 ,PersistFieldSql(..)+                                                 ,PersistValue(PersistText)+                                                 ,SqlType(SqlString)) import           Distribution.PackageDescription (TestSuiteInterface) import           Distribution.System             (Arch) import qualified Distribution.Text               as C-import           Path                            (mkRelDir, parseRelDir, (</>))+import           Distribution.Version            (mkVersion)+import           Path                            (parseRelDir, (</>), parent) import           Path.Extra                      (toFilePathNoTrailingSep) import           Stack.Constants-import           Stack.Types.BuildPlan import           Stack.Types.Compiler import           Stack.Types.CompilerBuild import           Stack.Types.Config-import           Stack.Types.FlagName import           Stack.Types.GhcPkgId import           Stack.Types.NamedComponent import           Stack.Types.Package-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName import           Stack.Types.Version-import           System.Exit                     (ExitCode (ExitFailure)) import           System.FilePath                 (pathSeparator) import           RIO.Process                     (showProcessArgDebug) @@ -89,8 +81,8 @@ data StackBuildException   = Couldn'tFindPkgId PackageName   | CompilerVersionMismatch-        (Maybe (CompilerVersion 'CVActual, Arch)) -- found-        (CompilerVersion 'CVWanted, Arch) -- expected+        (Maybe (ActualCompiler, Arch)) -- found+        (WantedCompiler, Arch) -- expected         GHCVariant -- expected         CompilerBuild -- expected         VersionCheck@@ -125,20 +117,24 @@         Version -- version specified on command line   | NoSetupHsFound (Path Abs Dir)   | InvalidFlagSpecification (Set UnusedFlags)+  | InvalidGhcOptionsSpecification [PackageName]   | TargetParseException [Text]-  | SolverGiveUp String-  | SolverMissingCabalInstall   | SomeTargetsNotBuildable [(PackageName, NamedComponent)]   | TestSuiteExeMissing Bool String String String   | CabalCopyFailed Bool String   | LocalPackagesPresent [PackageIdentifier]+  | CouldNotLockDistDir !(Path Abs File)   deriving Typeable  data FlagSource = FSCommandLine | FSStackYaml     deriving (Show, Eq, Ord)  data UnusedFlags = UFNoPackage FlagSource PackageName-                 | UFFlagsNotDefined FlagSource Package (Set FlagName)+                 | UFFlagsNotDefined+                       FlagSource+                       PackageName+                       (Set FlagName) -- defined in package+                       (Set FlagName) -- not defined                  | UFSnapshot PackageName     deriving (Show, Eq, Ord) @@ -163,7 +159,7 @@                     MatchMinor -> "minor version match with "                     MatchExact -> "exact version "                     NewerMinor -> "minor version match or newer with "-                , compilerVersionString expected+                , T.unpack $ utf8BuilderToText $ display expected                 , " ("                 , C.display earch                 , ghcVariantSuffix ghcVariant@@ -186,9 +182,7 @@             | otherwise = return $                 "The following target packages were not found: " ++                 intercalate ", " (map packageNameString $ Set.toList noKnown) ++-                "\nSee https://docs.haskellstack.org/en/v"-                <> versionString stackMinorVersion <>-                "/build_command/#target-syntax for details."+                "\nSee https://docs.haskellstack.org/en/stable/build_command/#target-syntax for details."         notInSnapshot'             | Map.null notInSnapshot = []             | otherwise =@@ -257,7 +251,7 @@             , "' not found"             , showFlagSrc src             ]-        go (UFFlagsNotDefined src pkg flags) = concat+        go (UFFlagsNotDefined src pname pkgFlags flags) = concat             [ "- Package '"             , name             , "' does not define the following flags"@@ -271,37 +265,36 @@                           (map (\flag -> "  " ++ name ++ ":" ++ flagNameString flag)                                (Set.toList pkgFlags))             ]-          where name = packageNameString (packageName pkg)-                pkgFlags = packageDefinedFlags pkg+          where name = packageNameString pname         go (UFSnapshot name) = concat             [ "- Attempted to set flag on snapshot package "             , packageNameString name             , ", please add to extra-deps"             ]+    show (InvalidGhcOptionsSpecification unused) = unlines+        $ "Invalid GHC options specification:"+        : map showGhcOptionSrc unused+      where+        showGhcOptionSrc name = concat+            [ "- Package '"+            , packageNameString name+            , "' not found"+            ]     show (TargetParseException [err]) = "Error parsing targets: " ++ T.unpack err     show (TargetParseException errs) = unlines         $ "The following errors occurred while parsing the build targets:"         : map (("- " ++) . T.unpack) errs -    show (SolverGiveUp msg) = concat-        [ "\nSolver could not resolve package dependencies.\n"-        , "You can try the following:\n"-        , msg-        ]-    show SolverMissingCabalInstall = unlines-        [ "Solver requires that cabal be on your PATH"-        , "Try running 'stack install cabal-install'"-        ]     show (SomeTargetsNotBuildable xs) =         "The following components have 'buildable: False' set in the cabal configuration, and so cannot be targets:\n    " ++         T.unpack (renderPkgComponents xs) ++         "\nTo resolve this, either provide flags such that these components are buildable, or only specify buildable targets."-    show (TestSuiteExeMissing isSimpleBuildType exeName pkgName testName) =+    show (TestSuiteExeMissing isSimpleBuildType exeName pkgName' testName) =         missingExeError isSimpleBuildType $ concat             [ "Test suite executable \""             , exeName             , " not found for "-            , pkgName+            , pkgName'             , ":test:"             , testName             ]@@ -315,6 +308,11 @@     show (LocalPackagesPresent locals) = unlines       $ "Local packages are not allowed when using the script command. Packages found:"       : map (\ident -> "- " ++ packageIdentifierString ident) locals+    show (CouldNotLockDistDir lockFile) = unlines+      [ "Locking the dist directory failed, try to lock file:"+      , "  " ++ toFilePath lockFile+      , "Maybe you're running another copy of Stack?"+      ]  missingExeError :: Bool -> String -> String missingExeError isSimpleBuildType msg =@@ -348,9 +346,9 @@   in "\n--  While building " ++      (case (isBuildingSetup, mtaskProvides) of        (False, Nothing) -> error "Invariant violated: unexpected case in showBuildError"-       (False, Just taskProvides') -> "package " ++ dropQuotes (show taskProvides')+       (False, Just taskProvides') -> "package " ++ dropQuotes (packageIdentifierString taskProvides')        (True, Nothing) -> "simple Setup.hs"-       (True, Just taskProvides') -> "custom Setup.hs for package " ++ dropQuotes (show taskProvides')+       (True, Just taskProvides') -> "custom Setup.hs for package " ++ dropQuotes (packageIdentifierString taskProvides')      ) ++      " using:\n      " ++ fullCmd ++ "\n" ++      "    Process exited with code: " ++ show exitCode ++@@ -372,20 +370,16 @@ -- | Package dependency oracle. newtype PkgDepsOracle =     PkgDeps PackageName-    deriving (Show,Typeable,Eq,Hashable,Store,NFData)+    deriving (Show,Typeable,Eq,NFData)  -- | Stored on disk to know whether the files have changed. newtype BuildCache = BuildCache     { buildCacheTimes :: Map FilePath FileCacheInfo       -- ^ Modification times of files.     }-    deriving (Generic, Eq, Show, Data, Typeable)+    deriving (Generic, Eq, Show, Typeable, ToJSON, FromJSON) instance NFData BuildCache-instance Store BuildCache -buildCacheVC :: VersionConfig BuildCache-buildCacheVC = storeVersionConfig "build-v1" "KVUoviSWWAd7tiRRGeWAvd0UIN4="- -- | Stored on disk to know whether the flags have changed. data ConfigCache = ConfigCache     { configCacheOpts :: !ConfigureOpts@@ -402,23 +396,34 @@     , configCacheHaddock :: !Bool       -- ^ Are haddocks to be built?     , configCachePkgSrc :: !CachePkgSrc+    , configCachePathEnvVar :: !Text+    -- ^ Value of the PATH env var, see <https://github.com/commercialhaskell/stack/issues/3138>     }     deriving (Generic, Eq, Show, Data, Typeable)-instance Store ConfigCache instance NFData ConfigCache  data CachePkgSrc = CacheSrcUpstream | CacheSrcLocal FilePath-    deriving (Generic, Eq, Show, Data, Typeable)-instance Store CachePkgSrc+    deriving (Generic, Eq, Read, Show, Data, Typeable) instance NFData CachePkgSrc -toCachePkgSrc :: PackageSource -> CachePkgSrc-toCachePkgSrc (PSFiles lp _) = CacheSrcLocal (toFilePath (lpDir lp))-toCachePkgSrc PSIndex{} = CacheSrcUpstream+instance PersistField CachePkgSrc where+    toPersistValue CacheSrcUpstream = PersistText "upstream"+    toPersistValue (CacheSrcLocal fp) = PersistText ("local:" <> T.pack fp)+    fromPersistValue (PersistText t) = do+        if t == "upstream"+            then Right CacheSrcUpstream+            else case T.stripPrefix "local:" t of+                Just fp -> Right $ CacheSrcLocal (T.unpack fp)+                Nothing -> Left $ "Unexpected CachePkgSrc value: " <> t+    fromPersistValue _ = Left "Unexpected CachePkgSrc type" -configCacheVC :: VersionConfig ConfigCache-configCacheVC = storeVersionConfig "config-v3" "z7N_NxX7Gbz41Gi9AGEa1zoLE-4="+instance PersistFieldSql CachePkgSrc where+    sqlType _ = SqlString +toCachePkgSrc :: PackageSource -> CachePkgSrc+toCachePkgSrc (PSFilePath lp) = CacheSrcLocal (toFilePath (parent (lpCabalFile lp)))+toCachePkgSrc PSRemote{} = CacheSrcUpstream+ -- | A task to perform when building data Task = Task     { taskProvides        :: !PackageIdentifier -- FIXME turn this into a function on taskType?@@ -426,6 +431,7 @@     , taskType            :: !TaskType     -- ^ the task type, telling us how to build this     , taskConfigOpts      :: !TaskConfigOpts+    , taskBuildHaddock    :: !Bool     , taskPresent         :: !(Map PackageIdentifier GhcPkgId)     -- ^ GhcPkgIds of already-installed dependencies     , taskAllInOne        :: !Bool@@ -465,26 +471,48 @@  -- | The type of a task, either building local code or something from the -- package index (upstream)-data TaskType = TTFiles LocalPackage InstallLocation-              | TTIndex Package InstallLocation PackageIdentifierRevision -- FIXME major overhaul for PackageLocation?+data TaskType+  = TTLocalMutable LocalPackage+  | TTRemotePackage IsMutable Package PackageLocationImmutable     deriving Show -ttPackageLocation :: TaskType -> PackageLocationIndex FilePath-ttPackageLocation (TTFiles lp _) = PLOther (lpLocation lp)-ttPackageLocation (TTIndex _ _ pir) = PLIndex pir+data IsMutable+    = Mutable+    | Immutable+    deriving (Eq, Show) +instance Semigroup IsMutable where+    Mutable <> _ = Mutable+    _ <> Mutable = Mutable+    Immutable <> Immutable = Immutable++instance Monoid IsMutable where+    mempty = Immutable+    mappend = (<>)+ taskIsTarget :: Task -> Bool taskIsTarget t =     case taskType t of-        TTFiles lp _ -> lpWanted lp+        TTLocalMutable lp -> lpWanted lp         _ -> False  taskLocation :: Task -> InstallLocation taskLocation task =     case taskType task of-        TTFiles _ loc -> loc-        TTIndex _ loc _ -> loc+        TTLocalMutable _ -> Local+        TTRemotePackage Mutable _ _ -> Local+        TTRemotePackage Immutable _ _ -> Snap +taskTargetIsMutable :: Task -> IsMutable+taskTargetIsMutable task =+    case taskType task of+        TTLocalMutable _ -> Mutable+        TTRemotePackage mutable _ _ -> mutable++installLocationIsMutable :: InstallLocation -> IsMutable+installLocationIsMutable Snap = Immutable+installLocationIsMutable Local = Mutable+ -- | A complete plan of what needs to be built and how to do it data Plan = Plan     { planTasks :: !(Map PackageName Task)@@ -514,11 +542,11 @@               -> BaseConfigOpts               -> Map PackageIdentifier GhcPkgId -- ^ dependencies               -> Bool -- ^ local non-extra-dep?-              -> InstallLocation+              -> IsMutable               -> Package               -> ConfigureOpts-configureOpts econfig bco deps isLocal loc package = ConfigureOpts-    { coDirs = configureOptsDirs bco loc package+configureOpts econfig bco deps isLocal isMutable package = ConfigureOpts+    { coDirs = configureOptsDirs bco isMutable package     , coNoDirs = configureOptsNoDir econfig bco deps isLocal package     } @@ -548,28 +576,28 @@     ] || t == "--user"  configureOptsDirs :: BaseConfigOpts-                  -> InstallLocation+                  -> IsMutable                   -> Package                   -> [String]-configureOptsDirs bco loc package = concat+configureOptsDirs bco isMutable package = concat     [ ["--user", "--package-db=clear", "--package-db=global"]-    , map (("--package-db=" ++) . toFilePathNoTrailingSep) $ case loc of-        Snap -> bcoExtraDBs bco ++ [bcoSnapDB bco]-        Local -> bcoExtraDBs bco ++ [bcoSnapDB bco] ++ [bcoLocalDB bco]-    , [ "--libdir=" ++ toFilePathNoTrailingSep (installRoot </> $(mkRelDir "lib"))+    , map (("--package-db=" ++) . toFilePathNoTrailingSep) $ case isMutable of+        Immutable -> bcoExtraDBs bco ++ [bcoSnapDB bco]+        Mutable -> bcoExtraDBs bco ++ [bcoSnapDB bco] ++ [bcoLocalDB bco]+    , [ "--libdir=" ++ toFilePathNoTrailingSep (installRoot </> relDirLib)       , "--bindir=" ++ toFilePathNoTrailingSep (installRoot </> bindirSuffix)-      , "--datadir=" ++ toFilePathNoTrailingSep (installRoot </> $(mkRelDir "share"))-      , "--libexecdir=" ++ toFilePathNoTrailingSep (installRoot </> $(mkRelDir "libexec"))-      , "--sysconfdir=" ++ toFilePathNoTrailingSep (installRoot </> $(mkRelDir "etc"))+      , "--datadir=" ++ toFilePathNoTrailingSep (installRoot </> relDirShare)+      , "--libexecdir=" ++ toFilePathNoTrailingSep (installRoot </> relDirLibexec)+      , "--sysconfdir=" ++ toFilePathNoTrailingSep (installRoot </> relDirEtc)       , "--docdir=" ++ toFilePathNoTrailingSep docDir       , "--htmldir=" ++ toFilePathNoTrailingSep docDir       , "--haddockdir=" ++ toFilePathNoTrailingSep docDir]     ]   where     installRoot =-        case loc of-            Snap -> bcoSnapInstallRoot bco-            Local -> bcoLocalInstallRoot bco+        case isMutable of+            Immutable -> bcoSnapInstallRoot bco+            Mutable -> bcoLocalInstallRoot bco     docDir =         case pkgVerDir of             Nothing -> installRoot </> docDirSuffix@@ -602,37 +630,37 @@                            else "-") <>                        flagNameString name)                     (Map.toList flags)+    , map T.unpack $ packageCabalConfigOpts package     , concatMap (\x -> [compilerOptionsCabalFlag wc, T.unpack x]) (packageGhcOptions package)-    , map ("--extra-include-dirs=" ++) (Set.toList (configExtraIncludeDirs config))-    , map ("--extra-lib-dirs=" ++) (Set.toList (configExtraLibDirs config))+    , map ("--extra-include-dirs=" ++) (configExtraIncludeDirs config)+    , map ("--extra-lib-dirs=" ++) (configExtraLibDirs config)     , maybe [] (\customGcc -> ["--with-gcc=" ++ toFilePath customGcc]) (configOverrideGccPath config)     , ["--ghcjs" | wc == Ghcjs]-    , ["--exact-configuration" | useExactConf]+    , ["--exact-configuration"]+    , ["--ghc-option=-fhide-source-paths" | hideSourcePaths cv]     ]   where     wc = view (actualCompilerVersionL.to whichCompiler) econfig+    cv = view (actualCompilerVersionL.to getGhcVersion) econfig++    hideSourcePaths ghcVersion = ghcVersion >= mkVersion [8, 2] && configHideSourcePaths config+     config = view configL econfig     bopts = bcoBuildOpts bco -    -- TODO: instead always enable this when the cabal version is new-    -- enough. That way we'll detect bugs with --exact-configuration-    -- earlier. Cabal also might do less work then.-    useExactConf = configAllowNewer config--    newerCabal = view cabalVersionL econfig >= $(mkVersion "1.22")+    newerCabal = view cabalVersionL econfig >= mkVersion [1, 22]      -- Unioning atop defaults is needed so that all flags are specified     -- with --exact-configuration.-    flags | useExactConf = packageFlags package `Map.union` packageDefaultFlags package-          | otherwise = packageFlags package+    flags = packageFlags package `Map.union` packageDefaultFlags package      depOptions = map (uncurry toDepOption) $ Map.toList deps       where         toDepOption = if newerCabal then toDepOption1_22 else toDepOption1_18 -    toDepOption1_22 ident gid = concat+    toDepOption1_22 (PackageIdentifier name _) gid = concat         [ "--dependency="-        , packageNameString $ packageIdentifierName ident+        , packageNameString name         , "="         , ghcPkgIdString gid         ]@@ -650,15 +678,6 @@ wantedLocalPackages :: [LocalPackage] -> Set PackageName wantedLocalPackages = Set.fromList . map (packageName . lpPackage) . filter lpWanted --- | One-way conversion to serialized time.-modTime :: UTCTime -> ModTime-modTime x =-    ModTime-        ( toModifiedJulianDay-              (utctDay x)-        , toRational-              (utctDayTime x))- -- | Configure options to be sent to Setup.hs configure data ConfigureOpts = ConfigureOpts     { coDirs :: ![String]@@ -668,27 +687,18 @@     , coNoDirs :: ![String]     }     deriving (Show, Eq, Generic, Data, Typeable)-instance Store ConfigureOpts instance NFData ConfigureOpts  -- | Information on a compiled package: the library conf file (if relevant), -- the sublibraries (if present) and all of the executable paths.-data PrecompiledCache = PrecompiledCache-    -- Use FilePath instead of Path Abs File for Binary instances-    { pcLibrary :: !(Maybe FilePath)+data PrecompiledCache base = PrecompiledCache+    { pcLibrary :: !(Maybe (Path base File))     -- ^ .conf file inside the package database-    , pcSubLibs :: ![FilePath]+    , pcSubLibs :: ![Path base File]     -- ^ .conf file inside the package database, for each of the sublibraries-    , pcExes    :: ![FilePath]+    , pcExes    :: ![Path base File]     -- ^ Full paths to executables     }-    deriving (Show, Eq, Generic, Data, Typeable)-instance Store PrecompiledCache-instance NFData PrecompiledCache--precompiledCacheVC :: VersionConfig PrecompiledCache-#if MIN_VERSION_template_haskell(2,14,0)-precompiledCacheVC = storeVersionConfig "precompiled-v2" "1Q08F5_iKDGDMPCuBG0-Av9nEKk="-#else-precompiledCacheVC = storeVersionConfig "precompiled-v2" "55vMMtbIlS4UukKnSmjs1SrI01o="-#endif+    deriving (Show, Eq, Generic, Typeable)+instance NFData (PrecompiledCache Abs)+instance NFData (PrecompiledCache Rel)
− src/Stack/Types/BuildPlan.hs 
@@ -1,413 +0,0 @@-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE TypeFamilies               #-}--- | Shared types for various stackage packages.-module Stack.Types.BuildPlan-    ( -- * Types-      SnapshotDef (..)-    , snapshotDefVC-    , sdRawPathName-    , PackageLocation (..)-    , PackageLocationIndex (..)-    , RepoType (..)-    , Subdirs (..)-    , Repo (..)-    , Archive (..)-    , ExeName (..)-    , LoadedSnapshot (..)-    , loadedSnapshotVC-    , LoadedPackageInfo (..)-    , ModuleName (..)-    , fromCabalModuleName-    , ModuleInfo (..)-    , moduleInfoVC-    , setCompilerVersion-    , sdWantedCompilerVersion-    ) where--import           Data.Aeson (ToJSON (..), FromJSON (..), withText, object, (.=))-import           Data.Aeson.Extended (WithJSONWarnings (..), (..:), (..:?), withObjectWarnings, noJSONWarnings, (..!=))-import qualified Data.Map as Map-import qualified Data.Set as Set-import           Data.Store.Version-import           Data.Store.VersionTagged-import qualified Data.Text as T-import           Data.Text.Encoding (encodeUtf8)-import qualified Distribution.ModuleName as C-import qualified Distribution.Version as C-import           Network.HTTP.StackClient (parseRequest)-import           Stack.Prelude-import           Stack.Types.Compiler-import           Stack.Types.FlagName-import           Stack.Types.GhcPkgId-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Resolver-import           Stack.Types.Version-import           Stack.Types.VersionIntervals---- | A definition of a snapshot. This could be a Stackage snapshot or--- something custom. It does not include information on the global--- package database, this is added later.------ It may seem more logic to attach flags, options, etc, directly with--- the desired package. However, this isn't possible yet: our--- definition may contain tarballs or Git repos, and we don't actually--- know the package names contained there. Therefore, we capture all--- of this additional information by package name, and later in the--- snapshot load step we will resolve the contents of tarballs and--- repos, figure out package names, and assigned values appropriately.-data SnapshotDef = SnapshotDef-    { sdParent :: !(Either (CompilerVersion 'CVWanted) SnapshotDef)-    -- ^ The snapshot to extend from. This is either a specific-    -- compiler, or a @SnapshotDef@ which gives us more information-    -- (like packages). Ultimately, we'll end up with a-    -- @CompilerVersion@.-    , sdResolver        :: !LoadedResolver-    -- ^ The resolver that provides this definition.-    , sdResolverName    :: !Text-    -- ^ A user-friendly way of referring to this resolver.-    , sdLocations :: ![PackageLocationIndex Subdirs]-    -- ^ Where to grab all of the packages from.-    , sdDropPackages :: !(Set PackageName)-    -- ^ Packages present in the parent which should not be included-    -- here.-    , sdFlags :: !(Map PackageName (Map FlagName Bool))-    -- ^ Flag values to override from the defaults-    , sdHidden :: !(Map PackageName Bool)-    -- ^ Packages which should be hidden when registering. This will-    -- affect, for example, the import parser in the script-    -- command. We use a 'Map' instead of just a 'Set' to allow-    -- overriding the hidden settings in a parent snapshot.-    , sdGhcOptions :: !(Map PackageName [Text])-    -- ^ GHC options per package-    , sdGlobalHints :: !(Map PackageName (Maybe Version))-    -- ^ Hints about which packages are available globally. When-    -- actually building code, we trust the package database provided-    -- by GHC itself, since it may be different based on platform or-    -- GHC install. However, when we want to check the compatibility-    -- of a snapshot with some codebase without installing GHC (e.g.,-    -- during stack init), we would use this field.-    }-    deriving (Show, Eq, Data, Generic, Typeable)-instance Store SnapshotDef-instance NFData SnapshotDef--snapshotDefVC :: VersionConfig SnapshotDef-#if MIN_VERSION_template_haskell(2,14,0)-snapshotDefVC = storeVersionConfig "sd-v1" "u-V-7pmU0YA-nXZFI0UBIST3JdY="-#else-snapshotDefVC = storeVersionConfig "sd-v1" "CKo7nln8EXkw07Gq-4ATxszNZiE="-#endif---- | A relative file path including a unique string for the given--- snapshot.-sdRawPathName :: SnapshotDef -> String-sdRawPathName sd =-    T.unpack $ go $ sdResolver sd-  where-    go (ResolverStackage name) = renderSnapName name-    go (ResolverCompiler version) = compilerVersionText version-    go (ResolverCustom _ hash) = "custom-" <> sdResolverName sd <> "-" <> trimmedSnapshotHash hash---- | Modify the wanted compiler version in this snapshot. This is used--- when overriding via the `compiler` value in a custom snapshot or--- stack.yaml file. We do _not_ need to modify the snapshot's hash for--- this: all binary caches of a snapshot are stored in a filepath that--- encodes the actual compiler version in addition to the--- hash. Therefore, modifications here will not lead to any invalid--- data.-setCompilerVersion :: CompilerVersion 'CVWanted -> SnapshotDef -> SnapshotDef-setCompilerVersion cv =-    go-  where-    go sd =-      case sdParent sd of-        Left _ -> sd { sdParent = Left cv }-        Right sd' -> sd { sdParent = Right $ go sd' }---- | Where to get the contents of a package (including cabal file--- revisions) from.------ A GADT may be more logical than the index parameter, but this plays--- more nicely with Generic deriving.-data PackageLocation subdirs-  = PLFilePath !FilePath-    -- ^ Note that we use @FilePath@ and not @Path@s. The goal is: first parse-    -- the value raw, and then use @canonicalizePath@ and @parseAbsDir@.-  | PLArchive !(Archive subdirs)-  | PLRepo !(Repo subdirs)-  -- ^ Stored in a source control repository-    deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor)-instance (Store a) => Store (PackageLocation a)-instance (NFData a) => NFData (PackageLocation a)---- | Add in the possibility of getting packages from the index--- (including cabal file revisions). We have special handling of this--- case in many places in the codebase, and therefore represent it--- with a separate data type from 'PackageLocation'.-data PackageLocationIndex subdirs-  = PLIndex !PackageIdentifierRevision-    -- ^ Grab the package from the package index with the given-    -- version and (optional) cabal file info to specify the correct-    -- revision.-  | PLOther !(PackageLocation subdirs)-    deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor)-instance (Store a) => Store (PackageLocationIndex a)-instance (NFData a) => NFData (PackageLocationIndex a)---- | A package archive, could be from a URL or a local file--- path. Local file path archives are assumed to be unchanging--- over time, and so are allowed in custom snapshots.-data Archive subdirs = Archive-  { archiveUrl :: !Text-  , archiveSubdirs :: !subdirs-  , archiveHash :: !(Maybe StaticSHA256)-  }-    deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor)-instance Store a => Store (Archive a)-instance NFData a => NFData (Archive a)---- | The type of a source control repository.-data RepoType = RepoGit | RepoHg-    deriving (Generic, Show, Eq, Ord, Data, Typeable)-instance Store RepoType-instance NFData RepoType--data Subdirs-  = DefaultSubdirs-  | ExplicitSubdirs ![FilePath]-    deriving (Generic, Show, Eq, Data, Typeable)-instance Store Subdirs-instance NFData Subdirs-instance FromJSON Subdirs where-  parseJSON = fmap ExplicitSubdirs . parseJSON---- | Information on packages stored in a source control repository.-data Repo subdirs = Repo-    { repoUrl :: !Text-    , repoCommit :: !Text-    , repoType :: !RepoType-    , repoSubdirs :: !subdirs-    }-    deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor)-instance Store a => Store (Repo a)-instance NFData a => NFData (Repo a)--instance subdirs ~ Subdirs => ToJSON (PackageLocationIndex subdirs) where-    toJSON (PLIndex ident) = toJSON ident-    toJSON (PLOther loc) = toJSON loc--instance subdirs ~ Subdirs => ToJSON (PackageLocation subdirs) where-    toJSON (PLFilePath fp) = toJSON fp-    toJSON (PLArchive (Archive t DefaultSubdirs Nothing)) = toJSON t-    toJSON (PLArchive (Archive t subdirs msha)) = object $ concat-        [ ["location" .= t]-        , case subdirs of-            DefaultSubdirs    -> []-            ExplicitSubdirs x -> ["subdirs" .= x]-        , case msha of-            Nothing -> []-            Just sha -> ["sha256" .= staticSHA256ToText sha]-        ]-    toJSON (PLRepo (Repo url commit typ subdirs)) = object $ concat-        [ case subdirs of-            DefaultSubdirs -> []-            ExplicitSubdirs x -> ["subdirs" .= x]-        , [urlKey .= url]-        , ["commit" .= commit]-        ]-      where-        urlKey =-          case typ of-            RepoGit -> "git"-            RepoHg  -> "hg"--instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocationIndex subdirs)) where-    parseJSON v-        = (noJSONWarnings . PLIndex <$> parseJSON v)-      <|> (fmap PLOther <$> parseJSON v)--instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocation subdirs)) where-    parseJSON v-        = (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v)-        <|> repo v-        <|> archiveObject v-        <|> github v-      where-        file t = pure $ PLFilePath $ T.unpack t-        http t =-            case parseRequest $ T.unpack t of-                Left  _ -> fail $ "Could not parse URL: " ++ T.unpack t-                Right _ -> return $ PLArchive $ Archive t DefaultSubdirs Nothing--        repo = withObjectWarnings "PLRepo" $ \o -> do-          (repoType, repoUrl) <--            ((RepoGit, ) <$> o ..: "git") <|>-            ((RepoHg, ) <$> o ..: "hg")-          repoCommit <- o ..: "commit"-          repoSubdirs <- o ..:? "subdirs" ..!= DefaultSubdirs-          return $ PLRepo Repo {..}--        archiveObject = withObjectWarnings "PLArchive" $ \o -> do-          url <- o ..: "archive"-          subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs-          msha <- o ..:? "sha256"-          msha' <--            case msha of-              Nothing -> return Nothing-              Just t ->-                case mkStaticSHA256FromText t of-                  Left e -> fail $ "Invalid SHA256: " ++ T.unpack t ++ ", " ++ show e-                  Right x -> return $ Just x-          return $ PLArchive Archive-            { archiveUrl = url-            , archiveSubdirs = subdirs :: Subdirs-            , archiveHash = msha'-            }--        github = withObjectWarnings "PLArchive:github" $ \o -> do-          GitHubRepo ghRepo <- o ..: "github"-          commit <- o ..: "commit"-          subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs-          return $ PLArchive Archive-            { archiveUrl = "https://github.com/" <> ghRepo <> "/archive/" <> commit <> ".tar.gz"-            , archiveSubdirs = subdirs-            , archiveHash = Nothing-            }---- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains--- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar".-newtype GitHubRepo = GitHubRepo Text--instance FromJSON GitHubRepo where-    parseJSON = withText "GitHubRepo" $ \s -> do-        case T.split (== '/') s of-            [x, y] | not (T.null x || T.null y) -> return (GitHubRepo s)-            _ -> fail "expecting \"user/repo\""---- | Name of an executable.-newtype ExeName = ExeName { unExeName :: Text }-    deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData, Data, Typeable)---- | A fully loaded snapshot combined , including information gleaned from the--- global database and parsing cabal files.------ Invariant: a global package may not depend upon a snapshot package,--- a snapshot may not depend upon a local or project, and all--- dependencies must be satisfied.-data LoadedSnapshot = LoadedSnapshot-  { lsCompilerVersion :: !(CompilerVersion 'CVActual)-  , lsGlobals         :: !(Map PackageName (LoadedPackageInfo GhcPkgId))-  , lsPackages        :: !(Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)))-  }-    deriving (Generic, Show, Data, Eq, Typeable)-instance Store LoadedSnapshot-instance NFData LoadedSnapshot--loadedSnapshotVC :: VersionConfig LoadedSnapshot-#if MIN_VERSION_template_haskell(2,14,0)-loadedSnapshotVC = storeVersionConfig "ls-v5" "Rl-3KjZ1LqhIyGy-o0HCC-I6cRc="-#else-loadedSnapshotVC = storeVersionConfig "ls-v5" "CeSRWh1VU8v0__kwA__msbe6WlU="-#endif---- | Information on a single package for the 'LoadedSnapshot' which--- can be installed.------ Note that much of the information below (such as the package--- dependencies or exposed modules) can be conditional in the cabal--- file, which means it will vary based on flags, arch, and OS.-data LoadedPackageInfo loc = LoadedPackageInfo-    { lpiVersion :: !Version-    -- ^ This /must/ match the version specified within 'rpiDef'.-    , lpiLocation :: !loc-    -- ^ Where to get the package from. This could be a few different-    -- things:-    ---    -- * For a global package, it will be the @GhcPkgId@. (If we end-    -- up needing to rebuild this because we've changed a-    -- dependency, we will take it from the package index with no-    -- @CabalFileInfo@.-    ---    -- * For a dependency, it will be a @PackageLocation@.-    ---    -- * For a project package, it will be a @Path Abs Dir@.-    , lpiFlags :: !(Map FlagName Bool)-    -- ^ Flags to build this package with.-    , lpiGhcOptions :: ![Text]-    -- ^ GHC options to use when building this package.-    , lpiPackageDeps :: !(Map PackageName VersionIntervals)-    -- ^ All packages which must be built/copied/registered before-    -- this package.-    , lpiExposedModules :: !(Set ModuleName)-    -- ^ Modules exposed by this package's library-    , lpiHide :: !Bool-    -- ^ Should this package be hidden in the database. Affects the-    -- script interpreter's module name import parser.-    }-    deriving (Generic, Show, Eq, Data, Typeable, Functor)-instance Store a => Store (LoadedPackageInfo a)-instance NFData a => NFData (LoadedPackageInfo a)--data DepInfo = DepInfo-    { _diComponents :: !(Set Component)-    , _diRange      :: !VersionIntervals-    }-    deriving (Generic, Show, Eq, Data, Typeable)-instance Store DepInfo-instance NFData DepInfo--instance Semigroup DepInfo where-    DepInfo a x <> DepInfo b y = DepInfo-        (mappend a b)-        (intersectVersionIntervals x y)--instance Monoid DepInfo where-    mempty = DepInfo mempty (fromVersionRange C.anyVersion)-    mappend = (<>)--data Component = CompLibrary-               | CompExecutable-               | CompTestSuite-               | CompBenchmark-    deriving (Generic, Show, Eq, Ord, Data, Typeable, Enum, Bounded)-instance Store Component-instance NFData Component--newtype ModuleName = ModuleName { unModuleName :: ByteString }-  deriving (Show, Eq, Ord, Generic, Store, NFData, Typeable, Data)--fromCabalModuleName :: C.ModuleName -> ModuleName-fromCabalModuleName = ModuleName . encodeUtf8 . T.intercalate "." . map T.pack . C.components--newtype ModuleInfo = ModuleInfo-    { miModules      :: Map ModuleName (Set PackageName)-    }-  deriving (Show, Eq, Ord, Generic, Typeable, Data)-instance Store ModuleInfo-instance NFData ModuleInfo--instance Semigroup ModuleInfo where-  ModuleInfo x <> ModuleInfo y =-    ModuleInfo (Map.unionWith Set.union x y)--instance Monoid ModuleInfo where-  mempty = ModuleInfo mempty-  mappend = (<>)--moduleInfoVC :: VersionConfig ModuleInfo-moduleInfoVC = storeVersionConfig "mi-v2" "8ImAfrwMVmqoSoEpt85pLvFeV3s="---- | Determined the desired compiler version for this 'SnapshotDef'.-sdWantedCompilerVersion :: SnapshotDef -> CompilerVersion 'CVWanted-sdWantedCompilerVersion = either id sdWantedCompilerVersion . sdParent
+ src/Stack/Types/Cache.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Stack.Types.Cache+    ( ConfigCacheType(..)+    , Action(..)+    ) where++import qualified Data.Text as T+import Database.Persist.Sql+import Stack.Prelude+import Stack.Types.GhcPkgId++-- | Type of config cache+data ConfigCacheType+    = ConfigCacheTypeConfig+    | ConfigCacheTypeFlagLibrary GhcPkgId+    | ConfigCacheTypeFlagExecutable PackageIdentifier+    deriving (Eq, Show)++instance PersistField ConfigCacheType where+    toPersistValue ConfigCacheTypeConfig = PersistText "config"+    toPersistValue (ConfigCacheTypeFlagLibrary v) =+        PersistText $ "lib:" <> unGhcPkgId v+    toPersistValue (ConfigCacheTypeFlagExecutable v) =+        PersistText $ "exe:" <> T.pack (packageIdentifierString v)+    fromPersistValue (PersistText t) =+        fromMaybe (Left $ "Unexected ConfigCacheType value: " <> t) $+        config <|> fmap lib (T.stripPrefix "lib:" t) <|>+        fmap exe (T.stripPrefix "exe:" t)+      where+        config+            | t == "config" = Just (Right ConfigCacheTypeConfig)+            | otherwise = Nothing+        lib v = do+            ghcPkgId <- mapLeft tshow (parseGhcPkgId v)+            Right $ ConfigCacheTypeFlagLibrary ghcPkgId+        exe v = do+            pkgId <-+                maybe (Left $ "Unexpected ConfigCacheType value: " <> t) Right $+                parsePackageIdentifier (T.unpack v)+            Right $ ConfigCacheTypeFlagExecutable pkgId+    fromPersistValue _ = Left "Unexected ConfigCacheType type"++instance PersistFieldSql ConfigCacheType where+    sqlType _ = SqlString++data Action+  = UpgradeCheck+  deriving (Show, Eq, Ord)+instance PersistField Action where+    toPersistValue UpgradeCheck = PersistInt64 1+    fromPersistValue (PersistInt64 1) = Right UpgradeCheck+    fromPersistValue x = Left $ T.pack $ "Invalid Action: " ++ show x+instance PersistFieldSql Action where+    sqlType _ = SqlInt64
src/Stack/Types/Compiler.hs view
@@ -4,16 +4,31 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} -module Stack.Types.Compiler where+module Stack.Types.Compiler+  ( ActualCompiler (..)+  , WhichCompiler (..)+  , CompilerRepository (..)+  , defaultCompilerRepository+  , getGhcVersion+  , whichCompiler+  , compilerVersionText+  , compilerVersionString+  , isWantedCompiler+  , wantedToActual+  , actualToWanted+  , parseActualCompiler+  ) where  import           Data.Aeson-import           Data.Data+import           Database.Persist+import           Database.Persist.Sql import qualified Data.Text as T+import           Data.Text (Text) import           Stack.Prelude import           Stack.Types.Version+import           Distribution.Version (mkVersion)  -- | Variety of compiler to use. data WhichCompiler@@ -21,86 +36,88 @@     | Ghcjs     deriving (Show, Eq, Ord) --- | Whether the compiler version given is the wanted version (what--- the stack.yaml file, snapshot file, or --resolver argument--- request), or the actual installed GHC. Depending on the matching--- requirements, these values could be different.-data CVType = CVWanted | CVActual- -- | Specifies a compiler and its version number(s). -- -- Note that despite having this datatype, stack isn't in a hurry to -- support compilers other than GHC.-data CompilerVersion (cvType :: CVType)-    = GhcVersion {-# UNPACK #-} !Version-    | GhcjsVersion-        {-# UNPACK #-} !Version -- GHCJS version-        {-# UNPACK #-} !Version -- GHC version+data ActualCompiler+    = ACGhc !Version+    | ACGhcGit !Text !Text+    | ACGhcjs+        !Version -- GHCJS version+        !Version -- GHC version     deriving (Generic, Show, Eq, Ord, Data, Typeable)-instance Store (CompilerVersion a)-instance NFData (CompilerVersion a)-instance Display (CompilerVersion a) where-    display = display . compilerVersionText-instance ToJSON (CompilerVersion a) where+instance NFData ActualCompiler+instance Display ActualCompiler where+    display (ACGhc x) = display (WCGhc x)+    display (ACGhcjs x y) = display (WCGhcjs x y)+    display (ACGhcGit x y) = display (WCGhcGit x y)+instance ToJSON ActualCompiler where     toJSON = toJSON . compilerVersionText-instance FromJSON (CompilerVersion a) where-    parseJSON (String t) = maybe (fail "Failed to parse compiler version") return (parseCompilerVersion t)+instance FromJSON ActualCompiler where+    parseJSON (String t) = either (const $ fail "Failed to parse compiler version") return (parseActualCompiler t)     parseJSON _ = fail "Invalid CompilerVersion, must be String"-instance FromJSONKey (CompilerVersion a) where+instance FromJSONKey ActualCompiler where     fromJSONKey = FromJSONKeyTextParser $ \k ->-        case parseCompilerVersion k of-            Nothing -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k-            Just parsed -> return parsed+        case parseActualCompiler k of+            Left _ -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k+            Right parsed -> return parsed+instance PersistField ActualCompiler where+  toPersistValue = toPersistValue . compilerVersionText+  fromPersistValue = (mapLeft tshow . parseActualCompiler) <=< fromPersistValue+instance PersistFieldSql ActualCompiler where+  sqlType _ = SqlString -actualToWanted :: CompilerVersion 'CVActual -> CompilerVersion 'CVWanted-actualToWanted (GhcVersion x) = GhcVersion x-actualToWanted (GhcjsVersion x y) = GhcjsVersion x y+wantedToActual :: WantedCompiler -> ActualCompiler+wantedToActual (WCGhc x) = ACGhc x+wantedToActual (WCGhcjs x y) = ACGhcjs x y+wantedToActual (WCGhcGit x y) = ACGhcGit x y -wantedToActual :: CompilerVersion 'CVWanted -> CompilerVersion 'CVActual-wantedToActual (GhcVersion x) = GhcVersion x-wantedToActual (GhcjsVersion x y) = GhcjsVersion x y+actualToWanted :: ActualCompiler -> WantedCompiler+actualToWanted (ACGhc x) = WCGhc x+actualToWanted (ACGhcjs x y) = WCGhcjs x y+actualToWanted (ACGhcGit x y) = WCGhcGit x y -parseCompilerVersion :: T.Text -> Maybe (CompilerVersion a)-parseCompilerVersion t-    | Just t' <- T.stripPrefix "ghc-" t-    , Just v <- parseVersionFromString $ T.unpack t'-        = Just (GhcVersion v)-    | Just t' <- T.stripPrefix "ghcjs-" t-    , [tghcjs, tghc] <- T.splitOn "_ghc-" t'-    , Just vghcjs <- parseVersionFromString $ T.unpack tghcjs-    , Just vghc <- parseVersionFromString $ T.unpack tghc-        = Just (GhcjsVersion vghcjs vghc)-    | otherwise-        = Nothing+parseActualCompiler :: T.Text -> Either PantryException ActualCompiler+parseActualCompiler = fmap wantedToActual . parseWantedCompiler -compilerVersionText :: CompilerVersion a -> T.Text-compilerVersionText (GhcVersion vghc) =-    "ghc-" <> versionText vghc-compilerVersionText (GhcjsVersion vghcjs vghc) =-    "ghcjs-" <> versionText vghcjs <> "_ghc-" <> versionText vghc+compilerVersionText :: ActualCompiler -> T.Text+compilerVersionText = utf8BuilderToText . display -compilerVersionString :: CompilerVersion a -> String+compilerVersionString :: ActualCompiler -> String compilerVersionString = T.unpack . compilerVersionText -whichCompiler :: CompilerVersion a -> WhichCompiler-whichCompiler GhcVersion {} = Ghc-whichCompiler GhcjsVersion {} = Ghcjs+whichCompiler :: ActualCompiler -> WhichCompiler+whichCompiler ACGhc{} = Ghc+whichCompiler ACGhcGit{} = Ghc+whichCompiler ACGhcjs{} = Ghcjs -isWantedCompiler :: VersionCheck -> CompilerVersion 'CVWanted -> CompilerVersion 'CVActual -> Bool-isWantedCompiler check (GhcVersion wanted) (GhcVersion actual) =+isWantedCompiler :: VersionCheck -> WantedCompiler -> ActualCompiler -> Bool+isWantedCompiler check (WCGhc wanted) (ACGhc actual) =     checkVersion check wanted actual-isWantedCompiler check (GhcjsVersion wanted wantedGhc) (GhcjsVersion actual actualGhc) =+isWantedCompiler check (WCGhcjs wanted wantedGhc) (ACGhcjs actual actualGhc) =     checkVersion check wanted actual && checkVersion check wantedGhc actualGhc+isWantedCompiler _check (WCGhcGit wCommit wFlavour) (ACGhcGit aCommit aFlavour) =+    wCommit == aCommit && wFlavour == aFlavour isWantedCompiler _ _ _ = False -getGhcVersion :: CompilerVersion a -> Version-getGhcVersion (GhcVersion v) = v-getGhcVersion (GhcjsVersion _ v) = v+getGhcVersion :: ActualCompiler -> Version+getGhcVersion (ACGhc v) = v+getGhcVersion (ACGhcjs _ v) = v+getGhcVersion (ACGhcGit _ _) =+   -- We can't return the actual version without running the installed ghc.+   -- For now we assume that users of ghc-git use it with a recent commit so we+   -- return a version far in the future. This disables our hacks for older+   -- versions and passes version checking when we use newer features.+   mkVersion [999,0,0] -compilerExeName :: WhichCompiler -> String-compilerExeName Ghc = "ghc"-compilerExeName Ghcjs = "ghcjs"+-- | Repository containing the compiler sources+newtype CompilerRepository+  = CompilerRepository Text+  deriving (Show) -haddockExeName :: WhichCompiler -> String-haddockExeName Ghc = "haddock"-haddockExeName Ghcjs = "haddock-ghcjs"+instance FromJSON CompilerRepository where+  parseJSON = withText "CompilerRepository" (return . CompilerRepository)++defaultCompilerRepository :: CompilerRepository+defaultCompilerRepository = CompilerRepository "https://gitlab.haskell.org/ghc/ghc.git"
src/Stack/Types/CompilerBuild.hs view
@@ -7,7 +7,7 @@   ) where  import           Stack.Prelude-import           Data.Aeson.Extended (FromJSON, parseJSON, withText)+import           Pantry.Internal.AesonExtended (FromJSON, parseJSON, withText) import           Data.Text as T  data CompilerBuild
src/Stack/Types/Config.hs view
@@ -1,2056 +1,2118 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}---- | The Config type.--module Stack.Types.Config-  (-  -- * Main configuration types and classes-  -- ** HasPlatform & HasStackRoot-   HasPlatform(..)-  ,PlatformVariant(..)-  -- ** Config & HasConfig-  ,Config(..)-  ,HasConfig(..)-  ,askLatestSnapshotUrl-  ,explicitSetupDeps-  -- ** BuildConfig & HasBuildConfig-  ,BuildConfig(..)-  ,LocalPackages(..)-  ,LocalPackageView(..)-  ,lpvRoot-  ,lpvName-  ,lpvVersion-  ,lpvComponents-  ,stackYamlL-  ,projectRootL-  ,HasBuildConfig(..)-  -- ** GHCVariant & HasGHCVariant-  ,GHCVariant(..)-  ,ghcVariantName-  ,ghcVariantSuffix-  ,parseGHCVariant-  ,HasGHCVariant(..)-  ,snapshotsDir-  -- ** EnvConfig & HasEnvConfig-  ,EnvConfig(..)-  ,HasEnvConfig(..)-  ,getCompilerPath-  -- * Details-  -- ** ApplyGhcOptions-  ,ApplyGhcOptions(..)-  -- ** ConfigException-  ,HpackExecutable(..)-  ,ConfigException(..)-  -- ** WhichSolverCmd-  ,WhichSolverCmd(..)-  -- ** ConfigMonoid-  ,ConfigMonoid(..)-  ,configMonoidInstallGHCName-  ,configMonoidSystemGHCName-  ,parseConfigMonoid-  -- ** DumpLogs-  ,DumpLogs(..)-  -- ** EnvSettings-  ,EnvSettings(..)-  ,minimalEnvSettings-  ,defaultEnvSettings-  ,plainEnvSettings-  -- ** GlobalOpts & GlobalOptsMonoid-  ,GlobalOpts(..)-  ,GlobalOptsMonoid(..)-  ,StackYamlLoc(..)-  ,defaultLogLevel-  -- ** LoadConfig-  ,LoadConfig(..)-  -- ** PackageIndex, IndexName & IndexLocation--  -- Re-exports-  ,PackageIndex(..)-  ,IndexName(..)-  ,indexNameText-  -- ** Project & ProjectAndConfigMonoid-  ,Project(..)-  ,ProjectAndConfigMonoid(..)-  ,parseProjectAndConfigMonoid-  -- ** PvpBounds-  ,PvpBounds(..)-  ,PvpBoundsType(..)-  ,parsePvpBounds-  -- ** ColorWhen-  ,readColorWhen-  -- ** SCM-  ,SCM(..)-  -- * Paths-  ,bindirSuffix-  ,configInstalledCache-  ,configLoadedSnapshotCache-  ,GlobalInfoSource(..)-  ,getProjectWorkDir-  ,docDirSuffix-  ,flagCacheLocal-  ,extraBinDirs-  ,hpcReportDir-  ,installationRootDeps-  ,installationRootLocal-  ,bindirCompilerTools-  ,hoogleRoot-  ,hoogleDatabasePath-  ,packageDatabaseDeps-  ,packageDatabaseExtra-  ,packageDatabaseLocal-  ,platformOnlyRelDir-  ,platformGhcRelDir-  ,platformGhcVerOnlyRelDir-  ,useShaPathOnWindows-  ,shaPath-  ,shaPathForBytes-  ,workDirL-  -- * Command-specific types-  -- ** Eval-  ,EvalOpts(..)-  -- ** Exec-  ,ExecOpts(..)-  ,SpecialExecCmd(..)-  ,ExecOptsExtra(..)-  -- ** Setup-  ,DownloadInfo(..)-  ,VersionedDownloadInfo(..)-  ,GHCDownloadInfo(..)-  ,SetupInfo(..)-  ,SetupInfoLocation(..)-  -- ** Docker entrypoint-  ,DockerEntrypoint(..)-  ,DockerUser(..)-  ,module X-  -- * Lens helpers-  ,wantedCompilerVersionL-  ,actualCompilerVersionL-  ,buildOptsL-  ,globalOptsL-  ,buildOptsInstallExesL-  ,buildOptsMonoidHaddockL-  ,buildOptsMonoidTestsL-  ,buildOptsMonoidBenchmarksL-  ,buildOptsMonoidInstallExesL-  ,buildOptsHaddockL-  ,globalOptsBuildOptsMonoidL-  ,stackRootL-  ,configUrlsL-  ,cabalVersionL-  ,whichCompilerL-  ,envOverrideSettingsL-  ,loadedSnapshotL-  ,globalHintsL-  ,shouldForceGhcColorFlag-  ,appropriateGhcColorFlag-  -- * Lens reexport-  ,view-  ,to-  ) where--import           Control.Monad.Writer (tell)-import           Crypto.Hash (hashWith, SHA1(..))-import           Stack.Prelude-import           Data.Aeson.Extended-                 (ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object,-                  (.=), (..:), (..:?), (..!=), Value(Bool, String),-                  withObjectWarnings, WarningParser, Object, jsonSubWarnings,-                  jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings,-                  FromJSONKeyFunction (FromJSONKeyTextParser))-import           Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping))-import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))-import qualified Data.ByteString.Char8 as S8-import           Data.Coerce (coerce)-import           Data.List (stripPrefix)-import           Data.List.NonEmpty (NonEmpty)-import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Map as Map-import qualified Data.Map.Strict as M-import qualified Data.Monoid as Monoid-import           Data.Monoid.Map (MonoidMap(..))-import qualified Data.Set as Set-import qualified Data.Text as T-import           Data.Text.Encoding (encodeUtf8)-import           Data.Yaml (ParseException)-import qualified Data.Yaml as Yaml-import           Distribution.PackageDescription (GenericPackageDescription)-import qualified Distribution.PackageDescription as C-import           Distribution.System (Platform)-import qualified Distribution.Text-import qualified Distribution.Types.UnqualComponentName as C-import           Distribution.Version (anyVersion, mkVersion')-import           Generics.Deriving.Monoid (memptydefault, mappenddefault)-import           Lens.Micro (Lens', lens, _1, _2, to)-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.Constants-import           Stack.PackageIndex (HasCabalLoader (..), CabalLoader (clStackRoot))-import           Stack.Types.BuildPlan-import           Stack.Types.Compiler-import           Stack.Types.CompilerBuild-import           Stack.Types.Docker-import           Stack.Types.FlagName-import           Stack.Types.Image-import           Stack.Types.NamedComponent-import           Stack.Types.Nix-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageIndex-import           Stack.Types.PackageName-import           Stack.Types.Resolver-import           Stack.Types.Runner-import           Stack.Types.TemplateName-import           Stack.Types.Urls-import           Stack.Types.Version-import qualified System.FilePath as FilePath-import           System.PosixCompat.Types (UserID, GroupID, FileMode)-import           RIO.Process (ProcessContext, HasProcessContext (..), findExecutable)---- Re-exports-import           Stack.Types.Config.Build as X---- | The top-level Stackage configuration.-data Config =-  Config {configWorkDir             :: !(Path Rel Dir)-         -- ^ this allows to override .stack-work directory-         ,configUserConfigPath      :: !(Path Abs File)-         -- ^ Path to user configuration file (usually ~/.stack/config.yaml)-         ,configBuild               :: !BuildOpts-         -- ^ Build configuration-         ,configDocker              :: !DockerOpts-         -- ^ Docker configuration-         ,configNix                 :: !NixOpts-         -- ^ Execution environment (e.g nix-shell) configuration-         ,configProcessContextSettings :: !(EnvSettings -> IO ProcessContext)-         -- ^ Environment variables to be passed to external tools-         ,configLocalProgramsBase   :: !(Path Abs Dir)-         -- ^ Non-platform-specific path containing local installations-         ,configLocalPrograms       :: !(Path Abs Dir)-         -- ^ Path containing local installations (mainly GHC)-         ,configHideTHLoading       :: !Bool-         -- ^ Hide the Template Haskell "Loading package ..." messages from the-         -- console-         ,configPlatform            :: !Platform-         -- ^ The platform we're building for, used in many directory names-         ,configPlatformVariant     :: !PlatformVariant-         -- ^ Variant of the platform, also used in directory names-         ,configGHCVariant0         :: !(Maybe GHCVariant)-         -- ^ 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-         -- e.g. The latest snapshot file.-         -- A build plan name (e.g. lts5.9.yaml) is appended when downloading-         -- the build plan actually.-         ,configSystemGHC           :: !Bool-         -- ^ Should we use the system-installed GHC (on the PATH) if-         -- available? Can be overridden by command line options.-         ,configInstallGHC          :: !Bool-         -- ^ Should we automatically install GHC if missing or the wrong-         -- version is available? Can be overridden by command line options.-         ,configSkipGHCCheck        :: !Bool-         -- ^ Don't bother checking the GHC version or architecture.-         ,configSkipMsys            :: !Bool-         -- ^ On Windows: don't use a sandboxed MSYS-         ,configCompilerCheck       :: !VersionCheck-         -- ^ Specifies which versions of the compiler are acceptable.-         ,configLocalBin            :: !(Path Abs Dir)-         -- ^ Directory we should install executables into-         ,configRequireStackVersion :: !VersionRange-         -- ^ Require a version of stack within this range.-         ,configJobs                :: !Int-         -- ^ How many concurrent jobs to run, defaults to number of capabilities-         ,configOverrideGccPath     :: !(Maybe (Path Abs File))-         -- ^ Optional gcc override path-         ,configOverrideHpack       :: !HpackExecutable-         -- ^ Use Hpack executable (overrides bundled Hpack)-         ,configExtraIncludeDirs    :: !(Set FilePath)-         -- ^ --extra-include-dirs arguments-         ,configExtraLibDirs        :: !(Set FilePath)-         -- ^ --extra-lib-dirs arguments-         ,configConcurrentTests     :: !Bool-         -- ^ Run test suites concurrently-         ,configImage               :: !ImageOpts-         ,configTemplateParams      :: !(Map Text Text)-         -- ^ Parameters for templates.-         ,configScmInit             :: !(Maybe SCM)-         -- ^ Initialize SCM (e.g. git) when creating new projects.-         ,configGhcOptionsByName    :: !(Map PackageName [Text])-         -- ^ Additional GHC options to apply to specific packages.-         ,configGhcOptionsByCat     :: !(Map ApplyGhcOptions [Text])-         -- ^ Additional GHC options to apply to categories of packages-         ,configSetupInfoLocations  :: ![SetupInfoLocation]-         -- ^ Additional SetupInfo (inline or remote) to use to find tools.-         ,configPvpBounds           :: !PvpBounds-         -- ^ How PVP upper bounds should be added to packages-         ,configModifyCodePage      :: !Bool-         -- ^ Force the code page to UTF-8 on Windows-         ,configExplicitSetupDeps   :: !(Map (Maybe PackageName) Bool)-         -- ^ See 'explicitSetupDeps'. 'Nothing' provides the default value.-         ,configRebuildGhcOptions   :: !Bool-         -- ^ Rebuild on GHC options changes-         ,configApplyGhcOptions     :: !ApplyGhcOptions-         -- ^ Which packages to ghc-options on the command line apply to?-         ,configAllowNewer          :: !Bool-         -- ^ Ignore version ranges in .cabal files. Funny naming chosen to-         -- match cabal.-         ,configDefaultTemplate     :: !(Maybe TemplateName)-         -- ^ The default template to use when none is specified.-         -- (If Nothing, the default default is used.)-         ,configAllowDifferentUser  :: !Bool-         -- ^ Allow users other than the stack root owner to use the stack-         -- installation.-         ,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.-         ,configAllowLocals         :: !Bool-         -- ^ Are we allowed to build local packages? The script-         -- command disallows this.-         ,configSaveHackageCreds    :: !Bool-         -- ^ Should we save Hackage credentials to a file?-         ,configHackageBaseUrl      :: !Text-         -- ^ Hackage base URL used when uploading packages-         ,configRunner              :: !Runner-         ,configCabalLoader         :: !CabalLoader-         }--data HpackExecutable-    = HpackBundled-    | HpackCommand String-    deriving (Show, Read, Eq, Ord)---- | Which packages do ghc-options on the command line apply to?-data ApplyGhcOptions = AGOTargets -- ^ all local targets-                     | AGOLocals -- ^ all local packages, even non-targets-                     | AGOEverything -- ^ every package-  deriving (Show, Read, Eq, Ord, Enum, Bounded)--instance FromJSON ApplyGhcOptions where-    parseJSON = withText "ApplyGhcOptions" $ \t ->-        case t of-            "targets" -> return AGOTargets-            "locals" -> return AGOLocals-            "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-    -- ^ include local project bin directory, GHC_PACKAGE_PATH, etc-    , esIncludeGhcPackagePath :: !Bool-    -- ^ include the GHC_PACKAGE_PATH variable-    , esStackExe :: !Bool-    -- ^ set the STACK_EXE variable to the current executable name-    , esLocaleUtf8 :: !Bool-    -- ^ set the locale to C.UTF-8-    , esKeepGhcRts :: !Bool-    -- ^ if True, keep GHCRTS variable in environment-    }-    deriving (Show, Eq, Ord)--data ExecOpts = ExecOpts-    { eoCmd :: !SpecialExecCmd-    , eoArgs :: ![String]-    , eoExtra :: !ExecOptsExtra-    } deriving (Show)--data SpecialExecCmd-    = ExecCmd String-    | ExecRun-    | ExecGhc-    | ExecRunGhc-    deriving (Show, Eq)--data ExecOptsExtra-    = ExecOptsPlain-    | ExecOptsEmbellished-        { eoEnvSettings :: !EnvSettings-        , eoPackages :: ![String]-        , eoRtsOptions :: ![String]-        , eoCwd :: !(Maybe FilePath)-        }-    deriving (Show)--data EvalOpts = EvalOpts-    { evalArg :: !String-    , evalExtra :: !ExecOptsExtra-    } deriving (Show)---- | Parsed global command-line options.-data GlobalOpts = GlobalOpts-    { globalReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version-    , globalDockerEntrypoint :: !(Maybe DockerEntrypoint)-      -- ^ Data used when stack is acting as a Docker entrypoint (internal use only)-    , globalLogLevel     :: !LogLevel -- ^ Log level-    , globalTimeInLog    :: !Bool -- ^ Whether to include timings in logs.-    , globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'-    , globalResolver     :: !(Maybe AbstractResolver) -- ^ Resolver override-    , globalCompiler     :: !(Maybe (CompilerVersion 'CVWanted)) -- ^ Compiler override-    , globalTerminal     :: !Bool -- ^ We're in a terminal?-    , globalColorWhen    :: !ColorWhen -- ^ When to use ansi terminal colors-    , globalTermWidth    :: !(Maybe Int) -- ^ Terminal width override-    , globalStackYaml    :: !(StackYamlLoc FilePath) -- ^ Override project stack.yaml-    } deriving (Show)--data StackYamlLoc filepath-    = SYLDefault-    | SYLOverride !filepath-    | SYLNoConfig !(Path Abs Dir)-    -- ^ FilePath is the directory containing the script file, used-    -- for resolving custom snapshot files.-    deriving (Show,Functor,Foldable,Traversable)---- | Parsed global command-line options monoid.-data GlobalOptsMonoid = GlobalOptsMonoid-    { globalMonoidReExecVersion :: !(First String) -- ^ Expected re-exec in container version-    , 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 'CVWanted)) -- ^ Compiler override-    , globalMonoidTerminal     :: !(First Bool) -- ^ We're in a terminal?-    , globalMonoidColorWhen    :: !(First ColorWhen) -- ^ When to use ansi colors-    , globalMonoidTermWidth    :: !(First Int) -- ^ Terminal width override-    , globalMonoidStackYaml    :: !(First FilePath) -- ^ Override project stack.yaml-    } deriving (Show, Generic)--instance Semigroup GlobalOptsMonoid where-    (<>) = mappenddefault--instance Monoid GlobalOptsMonoid where-    mempty = memptydefault-    mappend = (<>)---- | Default logging level should be something useful but not crazy.-defaultLogLevel :: LogLevel-defaultLogLevel = LevelInfo--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.------ These are the components which know nothing about local configuration.-data BuildConfig = BuildConfig-    { bcConfig     :: !Config-    , bcSnapshotDef :: !SnapshotDef-      -- ^ Build plan wanted for this build-    , bcGHCVariant :: !GHCVariant-      -- ^ The variant of GHC used to select a GHC bindist.-    , bcPackages :: ![PackageLocation Subdirs]-      -- ^ Local packages-    , bcDependencies :: ![PackageLocationIndex Subdirs]-      -- ^ Extra dependencies specified in configuration.-      ---      -- These dependencies will not be installed to a shared location, and-      -- will override packages provided by the resolver.-    , bcExtraPackageDBs :: ![Path Abs Dir]-      -- ^ Extra package databases-    , bcStackYaml  :: !(Path Abs File)-      -- ^ Location of the stack.yaml file.-      ---      -- Note: if the STACK_YAML environment variable is used, this may be-      -- different from projectRootL </> "stack.yaml"-      ---      -- FIXME MSS 2016-12-08: is the above comment still true? projectRootL-      -- is defined in terms of bcStackYaml-    , bcFlags      :: !(Map PackageName (Map FlagName Bool))-      -- ^ Per-package flag overrides-    , bcImplicitGlobal :: !Bool-      -- ^ Are we loading from the implicit global stack.yaml? This is useful-      -- for providing better error messages.-    }--stackYamlL :: HasBuildConfig env => Lens' env (Path Abs File)-stackYamlL = buildConfigL.lens bcStackYaml (\x y -> x { bcStackYaml = y })---- | Directory containing the project's stack.yaml file-projectRootL :: HasBuildConfig env => Getting r env (Path Abs Dir)-projectRootL = stackYamlL.to parent---- | Configuration after the environment has been setup.-data EnvConfig = EnvConfig-    {envConfigBuildConfig :: !BuildConfig-    ,envConfigCabalVersion :: !Version-    -- ^ This is the version of Cabal that stack will use to compile Setup.hs files-    -- in the build process.-    ---    -- Note that this is not necessarily the same version as the one that stack-    -- depends on as a library and which is displayed when running-    -- @stack list-dependencies | grep Cabal@ in the stack project.-    ,envConfigCompilerVersion :: !(CompilerVersion 'CVActual)-    -- ^ The actual version of the compiler to be used, as opposed to-    -- 'wantedCompilerL', which provides the version specified by the-    -- build plan.-    ,envConfigCompilerBuild :: !CompilerBuild-    ,envConfigPackagesRef :: !(IORef (Maybe LocalPackages))-    -- ^ Cache for 'getLocalPackages'.-    ,envConfigLoadedSnapshot :: !LoadedSnapshot-    -- ^ The fully resolved snapshot information.-    }--data LocalPackages = LocalPackages-  { lpProject :: !(Map PackageName LocalPackageView)-  , lpDependencies :: !(Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath))-  }---- | A view of a local package needed for resolving components-data LocalPackageView = LocalPackageView-    { lpvCabalFP    :: !(Path Abs File)-    , lpvGPD        :: !GenericPackageDescription-    , lpvLoc        :: !(PackageLocation FilePath)-    }---- | Root directory for the given 'LocalPackageView'-lpvRoot :: LocalPackageView -> Path Abs Dir-lpvRoot = parent . lpvCabalFP---- | Package name for the given 'LocalPackageView-lpvName :: LocalPackageView -> PackageName-lpvName lpv =-  let PackageIdentifier name _version =-         fromCabalPackageIdentifier-       $ C.package-       $ C.packageDescription-       $ lpvGPD lpv-   in name---- | All components available in the given 'LocalPackageView'-lpvComponents :: LocalPackageView -> Set NamedComponent-lpvComponents lpv = Set.fromList $ concat-    [ maybe []  (const [CLib]) (C.condLibrary gpkg)-    , go CExe   (map fst . C.condExecutables)-    , go CTest  (map fst . C.condTestSuites)-    , go CBench (map fst . C.condBenchmarks)-    ]-  where-    gpkg = lpvGPD lpv-    go :: (T.Text -> NamedComponent)-       -> (C.GenericPackageDescription -> [C.UnqualComponentName])-       -> [NamedComponent]-    go wrapper f = map (wrapper . T.pack . C.unUnqualComponentName) $ f gpkg---- | Version for the given 'LocalPackageView-lpvVersion :: LocalPackageView -> Version-lpvVersion lpv =-  let PackageIdentifier _name version =-         fromCabalPackageIdentifier-       $ C.package-       $ C.packageDescription-       $ lpvGPD lpv-   in version---- | Value returned by 'Stack.Config.loadConfig'.-data LoadConfig = LoadConfig-    { lcConfig          :: !Config-      -- ^ Top-level Stack configuration.-    , lcLoadBuildConfig :: !(Maybe (CompilerVersion 'CVWanted) -> IO BuildConfig)-        -- ^ Action to load the remaining 'BuildConfig'.-    , lcProjectRoot     :: !(Maybe (Path Abs Dir))-        -- ^ The project root directory, if in a project.-    }--data PackageEntry = PackageEntry-    { peExtraDepMaybe :: !(Maybe TreatLikeExtraDep)-    , peLocation :: !(PackageLocation Subdirs)-    , peSubdirs :: !Subdirs-    }-    deriving Show---- | Should a package be treated just like an extra-dep?------ 'True' means, it will only be built as a dependency--- for others, and its test suite/benchmarks will not be run.------ Useful modifying an upstream package, see:--- https://github.com/commercialhaskell/stack/issues/219--- https://github.com/commercialhaskell/stack/issues/386-type TreatLikeExtraDep = Bool--instance FromJSON (WithJSONWarnings PackageEntry) where-    parseJSON (String t) = do-        WithJSONWarnings loc _ <- parseJSON $ String t-        return $ noJSONWarnings-            PackageEntry-                { peExtraDepMaybe = Nothing-                , peLocation = loc-                , peSubdirs = DefaultSubdirs-                }-    parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry-        <$> o ..:? "extra-dep"-        <*> jsonSubWarnings (o ..: "location")-        <*> o ..:? "subdirs" ..!= DefaultSubdirs) v---- | A project is a collection of packages. We can have multiple stack.yaml--- files, but only one of them may contain project information.-data Project = Project-    { projectUserMsg :: !(Maybe String)-    -- ^ A warning message to display to the user when the auto generated-    -- config may have issues.-    , projectPackages :: ![PackageLocation Subdirs]-    -- ^ Packages which are actually part of the project (as opposed-    -- to dependencies).-    ---    -- /NOTE/ Stack has always allowed these packages to be any kind-    -- of package location, but in reality only @PLFilePath@ really-    -- makes sense. We could consider replacing @[PackageLocation]@-    -- with @[FilePath]@ to properly enforce this idea, though it will-    -- slightly break backwards compatibility if someone really did-    -- want to treat such things as non-deps.-    , projectDependencies :: ![PackageLocationIndex Subdirs]-    -- ^ Dependencies defined within the stack.yaml file, to be-    -- applied on top of the snapshot.-    , projectFlags :: !(Map PackageName (Map FlagName Bool))-    -- ^ Flags to be applied on top of the snapshot flags.-    , projectResolver :: !Resolver-    -- ^ How we resolve which @SnapshotDef@ to use-    , projectCompiler :: !(Maybe (CompilerVersion 'CVWanted))-    -- ^ When specified, overrides which compiler to use-    , projectExtraPackageDBs :: ![FilePath]-    }-  deriving Show--instance ToJSON Project where-    -- Expanding the constructor fully to ensure we don't miss any fields.-    toJSON (Project userMsg packages extraDeps flags resolver compiler extraPackageDBs) = object $ concat-      [ maybe [] (\cv -> ["compiler" .= cv]) compiler-      , maybe [] (\msg -> ["user-message" .= msg]) userMsg-      , if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs]-      , if null extraDeps then [] else ["extra-deps" .= extraDeps]-      , if Map.null flags then [] else ["flags" .= flags]-      , ["packages" .= packages]-      , ["resolver" .= resolver]-      ]---- An uninterpreted representation of configuration options.--- Configurations may be "cascaded" using mappend (left-biased).-data ConfigMonoid =-  ConfigMonoid-    { configMonoidStackRoot          :: !(First (Path Abs Dir))-    -- ^ See: 'clStackRoot'-    , configMonoidWorkDir            :: !(First (Path Rel Dir))-    -- ^ See: 'configWorkDir'.-    , configMonoidBuildOpts          :: !BuildOptsMonoid-    -- ^ build options.-    , configMonoidDockerOpts         :: !DockerOptsMonoid-    -- ^ Docker options.-    , configMonoidNixOpts            :: !NixOptsMonoid-    -- ^ Options for the execution environment (nix-shell or container)-    , configMonoidConnectionCount    :: !(First Int)-    -- ^ See: 'configConnectionCount'-    , configMonoidHideTHLoading      :: !(First Bool)-    -- ^ See: 'configHideTHLoading'-    , configMonoidLatestSnapshotUrl  :: !(First Text)-    -- ^ Deprecated in favour of 'urlsMonoidLatestSnapshot'-    , configMonoidUrls               :: !UrlsMonoid-    -- ^ See: 'configUrls-    , configMonoidPackageIndices     :: !(First [PackageIndex])-    -- ^ See: @picIndices@-    , configMonoidSystemGHC          :: !(First Bool)-    -- ^ See: 'configSystemGHC'-    ,configMonoidInstallGHC          :: !(First Bool)-    -- ^ See: 'configInstallGHC'-    ,configMonoidSkipGHCCheck        :: !(First Bool)-    -- ^ See: 'configSkipGHCCheck'-    ,configMonoidSkipMsys            :: !(First Bool)-    -- ^ See: 'configSkipMsys'-    ,configMonoidCompilerCheck       :: !(First VersionCheck)-    -- ^ See: 'configCompilerCheck'-    ,configMonoidRequireStackVersion :: !IntersectingVersionRange-    -- ^ See: 'configRequireStackVersion'-    ,configMonoidArch                :: !(First String)-    -- ^ Used for overriding the platform-    ,configMonoidGHCVariant          :: !(First GHCVariant)-    -- ^ Used for overriding the platform-    ,configMonoidGHCBuild            :: !(First CompilerBuild)-    -- ^ Used for overriding the GHC build-    ,configMonoidJobs                :: !(First Int)-    -- ^ See: 'configJobs'-    ,configMonoidExtraIncludeDirs    :: !(Set FilePath)-    -- ^ See: 'configExtraIncludeDirs'-    ,configMonoidExtraLibDirs        :: !(Set FilePath)-    -- ^ See: 'configExtraLibDirs'-    , configMonoidOverrideGccPath    :: !(First (Path Abs File))-    -- ^ Allow users to override the path to gcc-    ,configMonoidOverrideHpack       :: !(First FilePath)-    -- ^ Use Hpack executable (overrides bundled Hpack)-    ,configMonoidConcurrentTests     :: !(First Bool)-    -- ^ See: 'configConcurrentTests'-    ,configMonoidLocalBinPath        :: !(First FilePath)-    -- ^ Used to override the binary installation dir-    ,configMonoidImageOpts           :: !ImageOptsMonoid-    -- ^ Image creation options.-    ,configMonoidTemplateParameters  :: !(Map Text Text)-    -- ^ Template parameters.-    ,configMonoidScmInit             :: !(First SCM)-    -- ^ Initialize SCM (e.g. git init) when making new projects?-    ,configMonoidGhcOptionsByName    :: !(MonoidMap PackageName (Monoid.Dual [Text]))-    -- ^ See 'configGhcOptionsByName'. Uses 'Monoid.Dual' so that-    -- options from the configs on the right come first, so that they-    -- can be overridden.-    ,configMonoidGhcOptionsByCat     :: !(MonoidMap ApplyGhcOptions (Monoid.Dual [Text]))-    -- ^ See 'configGhcOptionsAll'. Uses 'Monoid.Dual' so that options-    -- from the configs on the right come first, so that they can be-    -- overridden.-    ,configMonoidExtraPath           :: ![Path Abs Dir]-    -- ^ 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)-    -- ^ See 'configModifyCodePage'-    ,configMonoidExplicitSetupDeps   :: !(Map (Maybe PackageName) Bool)-    -- ^ See 'configExplicitSetupDeps'-    ,configMonoidRebuildGhcOptions   :: !(First Bool)-    -- ^ See 'configMonoidRebuildGhcOptions'-    ,configMonoidApplyGhcOptions     :: !(First ApplyGhcOptions)-    -- ^ See 'configApplyGhcOptions'-    ,configMonoidAllowNewer          :: !(First Bool)-    -- ^ See 'configMonoidAllowNewer'-    ,configMonoidDefaultTemplate     :: !(First TemplateName)-    -- ^ The default template to use when none is specified.-    -- (If Nothing, the default default is used.)-    , configMonoidAllowDifferentUser :: !(First Bool)-    -- ^ Allow users other than the stack root owner to use the stack-    -- installation.-    , configMonoidDumpLogs           :: !(First DumpLogs)-    -- ^ See 'configDumpLogs'-    , configMonoidSaveHackageCreds   :: !(First Bool)-    -- ^ See 'configSaveHackageCreds'-    , configMonoidHackageBaseUrl     :: !(First Text)-    -- ^ See 'configHackageBaseUrl'-    , configMonoidIgnoreRevisionMismatch :: !(First Bool)-    -- ^ See 'configIgnoreRevisionMismatch'-    }-  deriving (Show, Generic)--instance Semigroup ConfigMonoid where-    (<>) = mappenddefault--instance Monoid ConfigMonoid where-    mempty = memptydefault-    mappend = (<>)--parseConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ConfigMonoid)-parseConfigMonoid = withObjectWarnings "ConfigMonoid" . parseConfigMonoidObject---- | Parse a partial configuration.  Used both to parse both a standalone config--- file and a project file, so that a sub-parser is not required, which would interfere with--- warnings for missing fields.-parseConfigMonoidObject :: Path Abs Dir -> Object -> WarningParser ConfigMonoid-parseConfigMonoidObject rootDir obj = do-    -- Parsing 'stackRoot' from 'stackRoot'/config.yaml would be nonsensical-    let configMonoidStackRoot = First Nothing-    configMonoidWorkDir <- First <$> obj ..:? configMonoidWorkDirName-    configMonoidBuildOpts <- jsonSubWarnings (obj ..:? configMonoidBuildOptsName ..!= mempty)-    configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty)-    configMonoidNixOpts <- jsonSubWarnings (obj ..:? configMonoidNixOptsName ..!= mempty)-    configMonoidConnectionCount <- First <$> obj ..:? configMonoidConnectionCountName-    configMonoidHideTHLoading <- First <$> obj ..:? configMonoidHideTHLoadingName-    configMonoidLatestSnapshotUrl <- First <$> obj ..:? configMonoidLatestSnapshotUrlName-    configMonoidUrls <- jsonSubWarnings (obj ..:? configMonoidUrlsName ..!= mempty)-    configMonoidPackageIndices <- First <$> jsonSubWarningsTT (obj ..:?  configMonoidPackageIndicesName)-    configMonoidSystemGHC <- First <$> obj ..:? configMonoidSystemGHCName-    configMonoidInstallGHC <- First <$> obj ..:? configMonoidInstallGHCName-    configMonoidSkipGHCCheck <- First <$> obj ..:? configMonoidSkipGHCCheckName-    configMonoidSkipMsys <- First <$> obj ..:? configMonoidSkipMsysName-    configMonoidRequireStackVersion <- IntersectingVersionRange . unVersionRangeJSON <$> (-                                       obj ..:? configMonoidRequireStackVersionName-                                           ..!= VersionRangeJSON anyVersion)-    configMonoidArch <- First <$> obj ..:? configMonoidArchName-    configMonoidGHCVariant <- First <$> obj ..:? configMonoidGHCVariantName-    configMonoidGHCBuild <- First <$> obj ..:? configMonoidGHCBuildName-    configMonoidJobs <- First <$> obj ..:? configMonoidJobsName-    configMonoidExtraIncludeDirs <- fmap (Set.map (toFilePath rootDir FilePath.</>)) $-        obj ..:?  configMonoidExtraIncludeDirsName ..!= Set.empty-    configMonoidExtraLibDirs <- fmap (Set.map (toFilePath rootDir FilePath.</>)) $-        obj ..:?  configMonoidExtraLibDirsName ..!= Set.empty-    configMonoidOverrideGccPath <- First <$> obj ..:? configMonoidOverrideGccPathName-    configMonoidOverrideHpack <- First <$> obj ..:? configMonoidOverrideHpackName-    configMonoidConcurrentTests <- First <$> obj ..:? configMonoidConcurrentTestsName-    configMonoidLocalBinPath <- First <$> obj ..:? configMonoidLocalBinPathName-    configMonoidImageOpts <- jsonSubWarnings (obj ..:?  configMonoidImageOptsName ..!= mempty)-    templates <- obj ..:? "templates"-    (configMonoidScmInit,configMonoidTemplateParameters) <--      case templates of-        Nothing -> return (First Nothing,M.empty)-        Just tobj -> do-          scmInit <- tobj ..:? configMonoidScmInitName-          params <- tobj ..:? configMonoidTemplateParametersName-          return (First scmInit,fromMaybe M.empty params)-    configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName--    options <- Map.map unGhcOptions <$> obj ..:? configMonoidGhcOptionsName ..!= mempty--    optionsEverything <--      case (Map.lookup GOKOldEverything options, Map.lookup GOKEverything options) of-        (Just _, Just _) -> fail "Cannot specify both `*` and `$everything` GHC options"-        (Nothing, Just x) -> return x-        (Just x, Nothing) -> do-          tell "The `*` ghc-options key is not recommended. Consider using $locals, or if really needed, $everything"-          return x-        (Nothing, Nothing) -> return []--    let configMonoidGhcOptionsByCat = coerce $ Map.fromList-          [ (AGOEverything, optionsEverything)-          , (AGOLocals, Map.findWithDefault [] GOKLocals options)-          , (AGOTargets, Map.findWithDefault [] GOKTargets options)-          ]--        configMonoidGhcOptionsByName = coerce $ Map.fromList-            [(name, opts) | (GOKPackage name, opts) <- Map.toList options]--    configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= []-    configMonoidSetupInfoLocations <--        maybeToList <$> jsonSubWarningsT (obj ..:?  configMonoidSetupInfoLocationsName)-    configMonoidLocalProgramsBase <- First <$> obj ..:? configMonoidLocalProgramsBaseName-    configMonoidPvpBounds <- First <$> obj ..:? configMonoidPvpBoundsName-    configMonoidModifyCodePage <- First <$> obj ..:? configMonoidModifyCodePageName-    configMonoidExplicitSetupDeps <--        (obj ..:? configMonoidExplicitSetupDepsName ..!= mempty)-        >>= fmap Map.fromList . mapM handleExplicitSetupDep . Map.toList-    configMonoidRebuildGhcOptions <- First <$> obj ..:? configMonoidRebuildGhcOptionsName-    configMonoidApplyGhcOptions <- First <$> obj ..:? configMonoidApplyGhcOptionsName-    configMonoidAllowNewer <- First <$> obj ..:? configMonoidAllowNewerName-    configMonoidDefaultTemplate <- First <$> obj ..:? configMonoidDefaultTemplateName-    configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName-    configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName-    configMonoidSaveHackageCreds <- First <$> obj ..:? configMonoidSaveHackageCredsName-    configMonoidHackageBaseUrl <- First <$> obj ..:? configMonoidHackageBaseUrlName-    configMonoidIgnoreRevisionMismatch <- First <$> obj ..:? configMonoidIgnoreRevisionMismatchName--    return ConfigMonoid {..}-  where-    handleExplicitSetupDep :: Monad m => (Text, Bool) -> m (Maybe PackageName, Bool)-    handleExplicitSetupDep (name', b) = do-        name <--            if name' == "*"-                then return Nothing-                else case parsePackageNameFromString $ T.unpack name' of-                        Left e -> fail $ show e-                        Right x -> return $ Just x-        return (name, b)--configMonoidWorkDirName :: Text-configMonoidWorkDirName = "work-dir"--configMonoidBuildOptsName :: Text-configMonoidBuildOptsName = "build"--configMonoidDockerOptsName :: Text-configMonoidDockerOptsName = "docker"--configMonoidNixOptsName :: Text-configMonoidNixOptsName = "nix"--configMonoidConnectionCountName :: Text-configMonoidConnectionCountName = "connection-count"--configMonoidHideTHLoadingName :: Text-configMonoidHideTHLoadingName = "hide-th-loading"--configMonoidLatestSnapshotUrlName :: Text-configMonoidLatestSnapshotUrlName = "latest-snapshot-url"--configMonoidUrlsName :: Text-configMonoidUrlsName = "urls"--configMonoidPackageIndicesName :: Text-configMonoidPackageIndicesName = "package-indices"--configMonoidSystemGHCName :: Text-configMonoidSystemGHCName = "system-ghc"--configMonoidInstallGHCName :: Text-configMonoidInstallGHCName = "install-ghc"--configMonoidSkipGHCCheckName :: Text-configMonoidSkipGHCCheckName = "skip-ghc-check"--configMonoidSkipMsysName :: Text-configMonoidSkipMsysName = "skip-msys"--configMonoidRequireStackVersionName :: Text-configMonoidRequireStackVersionName = "require-stack-version"--configMonoidArchName :: Text-configMonoidArchName = "arch"--configMonoidGHCVariantName :: Text-configMonoidGHCVariantName = "ghc-variant"--configMonoidGHCBuildName :: Text-configMonoidGHCBuildName = "ghc-build"--configMonoidJobsName :: Text-configMonoidJobsName = "jobs"--configMonoidExtraIncludeDirsName :: Text-configMonoidExtraIncludeDirsName = "extra-include-dirs"--configMonoidExtraLibDirsName :: Text-configMonoidExtraLibDirsName = "extra-lib-dirs"--configMonoidOverrideGccPathName :: Text-configMonoidOverrideGccPathName = "with-gcc"--configMonoidOverrideHpackName :: Text-configMonoidOverrideHpackName = "with-hpack"--configMonoidConcurrentTestsName :: Text-configMonoidConcurrentTestsName = "concurrent-tests"--configMonoidLocalBinPathName :: Text-configMonoidLocalBinPathName = "local-bin-path"--configMonoidImageOptsName :: Text-configMonoidImageOptsName = "image"--configMonoidScmInitName :: Text-configMonoidScmInitName = "scm-init"--configMonoidTemplateParametersName :: Text-configMonoidTemplateParametersName = "params"--configMonoidCompilerCheckName :: Text-configMonoidCompilerCheckName = "compiler-check"--configMonoidGhcOptionsName :: Text-configMonoidGhcOptionsName = "ghc-options"--configMonoidExtraPathName :: Text-configMonoidExtraPathName = "extra-path"--configMonoidSetupInfoLocationsName :: Text-configMonoidSetupInfoLocationsName = "setup-info"--configMonoidLocalProgramsBaseName :: Text-configMonoidLocalProgramsBaseName = "local-programs-path"--configMonoidPvpBoundsName :: Text-configMonoidPvpBoundsName = "pvp-bounds"--configMonoidModifyCodePageName :: Text-configMonoidModifyCodePageName = "modify-code-page"--configMonoidExplicitSetupDepsName :: Text-configMonoidExplicitSetupDepsName = "explicit-setup-deps"--configMonoidRebuildGhcOptionsName :: Text-configMonoidRebuildGhcOptionsName = "rebuild-ghc-options"--configMonoidApplyGhcOptionsName :: Text-configMonoidApplyGhcOptionsName = "apply-ghc-options"--configMonoidAllowNewerName :: Text-configMonoidAllowNewerName = "allow-newer"--configMonoidDefaultTemplateName :: Text-configMonoidDefaultTemplateName = "default-template"--configMonoidAllowDifferentUserName :: Text-configMonoidAllowDifferentUserName = "allow-different-user"--configMonoidDumpLogsName :: Text-configMonoidDumpLogsName = "dump-logs"--configMonoidSaveHackageCredsName :: Text-configMonoidSaveHackageCredsName = "save-hackage-creds"--configMonoidHackageBaseUrlName :: Text-configMonoidHackageBaseUrlName = "hackage-base-url"--configMonoidIgnoreRevisionMismatchName :: Text-configMonoidIgnoreRevisionMismatchName = "ignore-revision-mismatch"--data ConfigException-  = ParseConfigFileException (Path Abs File) ParseException-  | ParseCustomSnapshotException Text ParseException-  | NoProjectConfigFound (Path Abs Dir) (Maybe Text)-  | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File]-  | UnableToExtractArchive Text (Path Abs File)-  | BadStackVersionException VersionRange-  | NoMatchingSnapshot WhichSolverCmd (NonEmpty SnapName)-  | ResolverMismatch WhichSolverCmd !Text String -- Text == resolver name, sdName-  | ResolverPartial WhichSolverCmd !Text String -- Text == resolver name, sdName-  | 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-  | NoResolverWhenUsingNoLocalConfig-  | InvalidResolverForNoLocalConfig String-  | DuplicateLocalPackageNames ![(PackageName, [PackageLocationIndex FilePath])]-  deriving Typeable-instance Show ConfigException where-    show (ParseConfigFileException configFile exception) = concat-        [ "Could not parse '"-        , toFilePath configFile-        , "':\n"-        , Yaml.prettyPrintParseException exception-        , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/"-        ]-    show (ParseCustomSnapshotException url exception) = concat-        [ "Could not parse '"-        , T.unpack url-        , "':\n"-        , Yaml.prettyPrintParseException exception-        -- FIXME: Link to docs about custom snapshots-        -- , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/"-        ]-    show (NoProjectConfigFound dir mcmd) = concat-        [ "Unable to find a stack.yaml file in the current directory ("-        , toFilePath dir-        , ") or its ancestors"-        , case mcmd of-            Nothing -> ""-            Just cmd -> "\nRecommended action: stack " ++ T.unpack cmd-        ]-    show (UnexpectedArchiveContents dirs files) = concat-        [ "When unpacking an archive specified in your stack.yaml file, "-        , "did not find expected contents. Expected: a single directory. Found: "-        , show ( map (toFilePath . dirname) dirs-               , map (toFilePath . filename) files-               )-        ]-    show (UnableToExtractArchive url file) = concat-        [ "Archive extraction failed. Tarballs and zip archives are supported, couldn't handle the following URL, "-        , T.unpack url, " downloaded to the file ", toFilePath $ filename file-        ]-    show (BadStackVersionException requiredRange) = concat-        [ "The version of stack you are using ("-        , show (fromCabalVersion (mkVersion' Meta.version))-        , ") is outside the required\n"-        ,"version range specified in stack.yaml ("-        , T.unpack (versionRangeText requiredRange)-        , ")." ]-    show (NoMatchingSnapshot whichCmd names) = concat-        [ "None of the following snapshots provides a compiler matching "-        , "your package(s):\n"-        , unlines $ map (\name -> "    - " <> T.unpack (renderSnapName name))-                        (NonEmpty.toList names)-        , showOptions whichCmd Don'tSuggestSolver-        ]-    show (ResolverMismatch whichCmd resolver errDesc) = concat-        [ "Resolver '"-        , T.unpack resolver-        , "' does not have a matching compiler to build some or all of your "-        , "package(s).\n"-        , errDesc-        , showOptions whichCmd Don'tSuggestSolver-        ]-    show (ResolverPartial whichCmd resolver errDesc) = concat-        [ "Resolver '"-        , T.unpack resolver-        , "' 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-    show (ParseGHCVariantException v) =-        "Invalid ghc-variant value: " ++ v-    show (BadStackRoot stackRoot) = concat-        [ "Invalid stack root: '"-        , toFilePath stackRoot-        , "'. Please provide a valid absolute path."-        ]-    show (Won'tCreateStackRootInDirectoryOwnedByDifferentUser envStackRoot parentDir) = concat-        [ "Preventing creation of stack root '"-        , toFilePath envStackRoot-        , "'. Parent directory '"-        , toFilePath parentDir-        , "' is owned by someone else."-        ]-    show (UserDoesn'tOwnDirectory dir) = concat-        [ "You are not the owner of '"-        , toFilePath dir-        , "'. Aborting to protect file permissions."-        , "\nRetry with '--"-        , 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."-        ]-    show NoResolverWhenUsingNoLocalConfig = "When using the script command, you must provide a resolver argument"-    show (InvalidResolverForNoLocalConfig ar) = "The script command requires a specific resolver, you provided " ++ ar-    show (DuplicateLocalPackageNames pairs) = concat-        $ "The same package name is used in multiple local packages\n"-        : map go pairs-      where-        go (name, dirs) = unlines-            $ ""-            : (packageNameString name ++ " used in:")-            : map goLoc dirs-        goLoc loc = "- " ++ show loc-instance Exception ConfigException--showOptions :: WhichSolverCmd -> SuggestSolver -> String-showOptions whichCmd suggestSolver = unlines $ "\nThis may be resolved by:" : options-  where-    options =-        (case suggestSolver of-            SuggestSolver -> [useSolver]-            Don'tSuggestSolver -> []) ++-        (case whichCmd of-            IsSolverCmd -> [useResolver]-            IsInitCmd -> 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---- | Get the URL to request the information on the latest snapshots-askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text-askLatestSnapshotUrl = view $ configL.to configUrls.to urlsLatestSnapshot---- | @".stack-work"@-workDirL :: HasConfig env => Lens' env (Path Rel Dir)-workDirL = configL.lens configWorkDir (\x y -> x { configWorkDir = y })---- | Per-project work dir-getProjectWorkDir :: (HasBuildConfig env, MonadReader env m) => m (Path Abs Dir)-getProjectWorkDir = do-    root    <- view projectRootL-    workDir <- view workDirL-    return (root </> workDir)---- | File containing the installed cache, see "Stack.PackageDump"-configInstalledCache :: (HasBuildConfig env, MonadReader env m) => m (Path Abs File)-configInstalledCache = liftM (</> $(mkRelFile "installed-cache.bin")) getProjectWorkDir---- | Relative directory for the platform identifier-platformOnlyRelDir-    :: (MonadReader env m, HasPlatform env, MonadThrow m)-    => m (Path Rel Dir)-platformOnlyRelDir = do-    platform <- view platformL-    platformVariant <- view platformVariantL-    parseRelDir (Distribution.Text.display platform ++ platformVariantSuffix platformVariant)---- | Directory containing snapshots-snapshotsDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Abs Dir)-snapshotsDir = do-    root <- view stackRootL-    platform <- platformGhcRelDir-    return $ root </> $(mkRelDir "snapshots") </> platform---- | Installation root for dependencies-installationRootDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)-installationRootDeps = do-    root <- view stackRootL-    -- TODO: also useShaPathOnWindows here, once #1173 is resolved.-    psc <- platformSnapAndCompilerRel-    return $ root </> $(mkRelDir "snapshots") </> psc---- | Installation root for locals-installationRootLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)-installationRootLocal = do-    workDir <- getProjectWorkDir-    psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel-    return $ workDir </> $(mkRelDir "install") </> psc---- | Installation root for compiler tools-bindirCompilerTools :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)-bindirCompilerTools = do-    config <- view configL-    platform <- platformGhcRelDir-    compilerVersion <- envConfigCompilerVersion <$> view envConfigL-    compiler <- parseRelDir $ compilerVersionString compilerVersion-    return $-        view stackRootL config </>-        $(mkRelDir "compiler-tools") </>-        platform </>-        compiler </>-        bindirSuffix---- | Hoogle directory.-hoogleRoot :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)-hoogleRoot = do-    workDir <- getProjectWorkDir-    psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel-    return $ workDir </> $(mkRelDir "hoogle") </> psc---- | Get the hoogle database path.-hoogleDatabasePath :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs File)-hoogleDatabasePath = do-    dir <- hoogleRoot-    return (dir </> $(mkRelFile "database.hoo"))---- | Path for platform followed by snapshot name followed by compiler--- name.-platformSnapAndCompilerRel-    :: (MonadReader env m, HasEnvConfig env, MonadThrow m)-    => m (Path Rel Dir)-platformSnapAndCompilerRel = do-    sd <- view snapshotDefL-    platform <- platformGhcRelDir-    name <- parseRelDir $ sdRawPathName sd-    ghc <- compilerVersionDir-    useShaPathOnWindows (platform </> name </> ghc)---- | Relative directory for the platform and GHC identifier-platformGhcRelDir-    :: (MonadReader env m, HasEnvConfig env, MonadThrow m)-    => m (Path Rel Dir)-platformGhcRelDir = do-    ec <- view envConfigL-    verOnly <- platformGhcVerOnlyRelDirStr-    parseRelDir (mconcat [ verOnly-                         , compilerBuildSuffix (envConfigCompilerBuild ec)])---- | Relative directory for the platform and GHC identifier without GHC bindist build-platformGhcVerOnlyRelDir-    :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)-    => m (Path Rel Dir)-platformGhcVerOnlyRelDir =-    parseRelDir =<< platformGhcVerOnlyRelDirStr---- | Relative directory for the platform and GHC identifier without GHC bindist build--- (before parsing into a Path)-platformGhcVerOnlyRelDirStr-    :: (MonadReader env m, HasPlatform env, HasGHCVariant env)-    => m FilePath-platformGhcVerOnlyRelDirStr = do-    platform <- view platformL-    platformVariant <- view platformVariantL-    ghcVariant <- view ghcVariantL-    return $ mconcat [ Distribution.Text.display platform-                     , platformVariantSuffix platformVariant-                     , ghcVariantSuffix ghcVariant ]---- | This is an attempt to shorten stack paths on Windows to decrease our--- chances of hitting 260 symbol path limit. The idea is to calculate--- SHA1 hash of the path used on other architectures, encode with base--- 16 and take first 8 symbols of it.-useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir)-useShaPathOnWindows =-#ifdef mingw32_HOST_OS-    shaPath-#else-    return-#endif--shaPath :: (IsPath Rel t, MonadThrow m) => Path Rel t -> m (Path Rel t)-shaPath = shaPathForBytes . encodeUtf8 . T.pack . toFilePath--shaPathForBytes :: (IsPath Rel t, MonadThrow m) => ByteString -> m (Path Rel t)-shaPathForBytes-    = parsePath . S8.unpack . S8.take 8-    . Mem.convertToBase Mem.Base16 . hashWith SHA1---- TODO: Move something like this into the path package. Consider--- subsuming path-io's 'AnyPath'?-class IsPath b t where-  parsePath :: MonadThrow m => FilePath -> m (Path b t)--instance IsPath Abs Dir where parsePath = parseAbsDir-instance IsPath Rel Dir where parsePath = parseRelDir-instance IsPath Abs File where parsePath = parseAbsFile-instance IsPath Rel File where parsePath = parseRelFile--compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir)-compilerVersionDir = do-    compilerVersion <- view actualCompilerVersionL-    parseRelDir $ case compilerVersion of-        GhcVersion version -> versionString version-        GhcjsVersion {} -> compilerVersionString compilerVersion---- | Package database for installing dependencies into-packageDatabaseDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)-packageDatabaseDeps = do-    root <- installationRootDeps-    return $ root </> $(mkRelDir "pkgdb")---- | Package database for installing local packages into-packageDatabaseLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)-packageDatabaseLocal = do-    root <- installationRootLocal-    return $ root </> $(mkRelDir "pkgdb")---- | Extra package databases-packageDatabaseExtra :: (MonadReader env m, HasEnvConfig env) => m [Path Abs Dir]-packageDatabaseExtra = view $ buildConfigL.to bcExtraPackageDBs---- | Directory for holding flag cache information-flagCacheLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)-flagCacheLocal = do-    root <- installationRootLocal-    return $ root </> $(mkRelDir "flag-cache")---- | Where to store 'LoadedSnapshot' caches-configLoadedSnapshotCache-  :: (MonadThrow m, MonadReader env m, HasConfig env, HasGHCVariant env)-  => SnapshotDef-  -> GlobalInfoSource-  -> m (Path Abs File)-configLoadedSnapshotCache sd gis = do-    root <- view stackRootL-    platform <- platformGhcVerOnlyRelDir-    file <- parseRelFile $ sdRawPathName sd ++ ".cache"-    gis' <- parseRelDir $-          case gis of-            GISSnapshotHints -> "__snapshot_hints__"-            GISCompiler cv -> compilerVersionString cv-    -- Yes, cached plans differ based on platform-    return (root </> $(mkRelDir "loaded-snapshot-cache") </> platform </> gis' </> file)---- | Where do we get information on global packages for loading up a--- 'LoadedSnapshot'?-data GlobalInfoSource-  = GISSnapshotHints-  -- ^ Accept the hints in the snapshot definition-  | GISCompiler (CompilerVersion 'CVActual)-  -- ^ Look up the actual information in the installed compiler---- | Suffix applied to an installation root to get the bin dir-bindirSuffix :: Path Rel Dir-bindirSuffix = $(mkRelDir "bin")---- | Suffix applied to an installation root to get the doc dir-docDirSuffix :: Path Rel Dir-docDirSuffix = $(mkRelDir "doc")---- | Where HPC reports and tix files get stored.-hpcReportDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env)-             => m (Path Abs Dir)-hpcReportDir = do-   root <- installationRootLocal-   return $ root </> $(mkRelDir "hpc")---- | Get the extra bin directories (for the PATH). Puts more local first------ Bool indicates whether or not to include the locals-extraBinDirs :: (MonadThrow m, MonadReader env m, HasEnvConfig env)-             => m (Bool -> [Path Abs Dir])-extraBinDirs = do-    deps <- installationRootDeps-    local' <- installationRootLocal-    tools <- bindirCompilerTools-    return $ \locals -> if locals-        then [local' </> bindirSuffix, deps </> bindirSuffix, tools]-        else [deps </> bindirSuffix, tools]--minimalEnvSettings :: EnvSettings-minimalEnvSettings =-    EnvSettings-    { esIncludeLocals = False-    , esIncludeGhcPackagePath = False-    , esStackExe = False-    , esLocaleUtf8 = False-    , esKeepGhcRts = False-    }---- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH.------ Note that this also passes through the GHCRTS environment variable.--- See https://github.com/commercialhaskell/stack/issues/3444-defaultEnvSettings :: EnvSettings-defaultEnvSettings = EnvSettings-    { esIncludeLocals = True-    , esIncludeGhcPackagePath = True-    , esStackExe = True-    , esLocaleUtf8 = False-    , esKeepGhcRts = True-    }---- | Environment settings which do not embellish the environment------ Note that this also passes through the GHCRTS environment variable.--- See https://github.com/commercialhaskell/stack/issues/3444-plainEnvSettings :: EnvSettings-plainEnvSettings = EnvSettings-    { esIncludeLocals = False-    , esIncludeGhcPackagePath = False-    , esStackExe = False-    , esLocaleUtf8 = False-    , esKeepGhcRts = True-    }---- | Get the path for the given compiler ignoring any local binaries.------ https://github.com/commercialhaskell/stack/issues/1052-getCompilerPath-    :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env)-    => WhichCompiler-    -> m (Path Abs File)-getCompilerPath wc = do-    config' <- view configL-    eoWithoutLocals <- liftIO $-        configProcessContextSettings config' minimalEnvSettings { esLocaleUtf8 = True }-    eres <- runRIO eoWithoutLocals $ findExecutable $ compilerExeName wc-    case eres of-      Left e -> throwM e-      Right x -> parseAbsFile x--data ProjectAndConfigMonoid-  = ProjectAndConfigMonoid !Project !ConfigMonoid--parseProjectAndConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ProjectAndConfigMonoid)-parseProjectAndConfigMonoid rootDir =-    withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do-        dirs <- jsonSubWarningsTT (o ..:? "packages") ..!= [packageEntryCurrDir]-        extraDeps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= []-        flags <- o ..:? "flags" ..!= mempty--        -- Convert the packages/extra-deps/flags approach we use in-        -- the stack.yaml into the internal representation.-        let (packages, deps) = convert dirs extraDeps--        resolver <- (o ..: "resolver")-                >>= either (fail . show) return-                  . parseCustomLocation (Just rootDir)-        compiler <- o ..:? "compiler"-        msg <- o ..:? "user-message"-        config <- parseConfigMonoidObject rootDir o-        extraPackageDBs <- o ..:? "extra-package-dbs" ..!= []-        let project = Project-                { projectUserMsg = msg-                , projectResolver = resolver-                , projectCompiler = compiler-                , projectExtraPackageDBs = extraPackageDBs-                , projectPackages = packages-                , projectDependencies = deps-                , projectFlags = flags-                }-        return $ ProjectAndConfigMonoid project config-      where-        convert :: [PackageEntry]-                -> [PackageLocationIndex Subdirs] -- extra-deps-                -> ( [PackageLocation Subdirs] -- project-                   , [PackageLocationIndex Subdirs] -- dependencies-                   )-        convert entries extraDeps =-            partitionEithers $ concatMap goEntry entries ++ map Right extraDeps-          where-            goEntry :: PackageEntry -> [Either (PackageLocation Subdirs) (PackageLocationIndex Subdirs)]-            goEntry (PackageEntry Nothing pl@(PLFilePath _) subdirs) = goEntry' False pl subdirs-            goEntry (PackageEntry Nothing pl _) = fail $ concat-              [ "Refusing to implicitly treat package location as an extra-dep:\n"-              , show pl-              , "\nRecommendation: either move to 'extra-deps' or set 'extra-dep: true'."-              ]-            goEntry (PackageEntry (Just extraDep) pl subdirs) = goEntry' extraDep pl subdirs--            goEntry' :: Bool -- ^ extra dep?-                     -> PackageLocation Subdirs-                     -> Subdirs-                     -> [Either (PackageLocation Subdirs) (PackageLocationIndex Subdirs)]-            goEntry' extraDep pl subdirs =-              map (if extraDep then Right . PLOther else Left) (addSubdirs pl subdirs)--            combineSubdirs :: [FilePath] -> Subdirs -> Subdirs-            combineSubdirs paths DefaultSubdirs = ExplicitSubdirs paths-            -- this could be considered an error condition, but we'll-            -- just try and make it work-            combineSubdirs paths (ExplicitSubdirs paths') = ExplicitSubdirs (paths ++ paths')--            -- We do the toList/fromList bit as an efficient nub, and-            -- to avoid having duplicate subdir names (especially for-            -- the "." case, where parsing gets wonky).-            addSubdirs :: PackageLocation Subdirs-                       -> Subdirs-                       -> [PackageLocation Subdirs]-            addSubdirs pl DefaultSubdirs = [pl]-            addSubdirs (PLRepo repo) (ExplicitSubdirs subdirs) =-              [PLRepo repo { repoSubdirs = combineSubdirs subdirs $ repoSubdirs repo }]-            addSubdirs (PLArchive arch) (ExplicitSubdirs subdirs) =-              [PLArchive arch { archiveSubdirs = combineSubdirs subdirs $ archiveSubdirs arch }]-            addSubdirs (PLFilePath fp) (ExplicitSubdirs subdirs) =-              map (\subdir -> PLFilePath $ fp FilePath.</> subdir) subdirs---- | A PackageEntry for the current directory, used as a default-packageEntryCurrDir :: PackageEntry-packageEntryCurrDir = PackageEntry-    { peExtraDepMaybe = Nothing-    , peLocation = PLFilePath "."-    , peSubdirs = DefaultSubdirs-    }---- | A software control system.-data SCM = Git-  deriving (Show)--instance FromJSON SCM where-    parseJSON v = do-        s <- parseJSON v-        case s of-            "git" -> return Git-            _ -> fail ("Unknown or unsupported SCM: " <> s)--instance ToJSON SCM where-    toJSON Git = toJSON ("git" :: Text)---- | A variant of the platform, used to differentiate Docker builds from host-data PlatformVariant = PlatformVariantNone-                     | PlatformVariant String---- | Render a platform variant to a String suffix.-platformVariantSuffix :: PlatformVariant -> String-platformVariantSuffix PlatformVariantNone = ""-platformVariantSuffix (PlatformVariant v) = "-" ++ v---- | Specialized bariant of GHC (e.g. libgmp4 or integer-simple)-data GHCVariant-    = GHCStandard -- ^ Standard bindist-    | GHCIntegerSimple -- ^ Bindist that uses integer-simple-    | GHCCustom String -- ^ Other bindists-    deriving (Show)--instance FromJSON GHCVariant where-    -- Strange structuring is to give consistent error messages-    parseJSON =-        withText-            "GHCVariant"-            (either (fail . show) return . parseGHCVariant . T.unpack)---- | Render a GHC variant to a String.-ghcVariantName :: GHCVariant -> String-ghcVariantName GHCStandard = "standard"-ghcVariantName GHCIntegerSimple = "integersimple"-ghcVariantName (GHCCustom name) = "custom-" ++ name---- | Render a GHC variant to a String suffix.-ghcVariantSuffix :: GHCVariant -> String-ghcVariantSuffix GHCStandard = ""-ghcVariantSuffix v = "-" ++ ghcVariantName v---- | Parse GHC variant from a String.-parseGHCVariant :: (MonadThrow m) => String -> m GHCVariant-parseGHCVariant s =-    case stripPrefix "custom-" s of-        Just name -> return (GHCCustom name)-        Nothing-          | s == "" -> return GHCStandard-          | s == "standard" -> return GHCStandard-          | s == "integersimple" -> return GHCIntegerSimple-          | otherwise -> return (GHCCustom s)---- | Build of the compiler distribution (e.g. standard, gmp4, tinfo6)--- | Information for a file to download.-data DownloadInfo = DownloadInfo-    { downloadInfoUrl :: Text-      -- ^ URL or absolute file path-    , downloadInfoContentLength :: Maybe Int-    , downloadInfoSha1 :: Maybe ByteString-    , downloadInfoSha256 :: Maybe ByteString-    } deriving (Show)--instance FromJSON (WithJSONWarnings DownloadInfo) where-    parseJSON = withObjectWarnings "DownloadInfo" parseDownloadInfoFromObject---- | Parse JSON in existing object for 'DownloadInfo'-parseDownloadInfoFromObject :: Object -> WarningParser DownloadInfo-parseDownloadInfoFromObject o = do-    url <- o ..: "url"-    contentLength <- o ..:? "content-length"-    sha1TextMay <- o ..:? "sha1"-    sha256TextMay <- o ..:? "sha256"-    return-        DownloadInfo-        { downloadInfoUrl = url-        , downloadInfoContentLength = contentLength-        , downloadInfoSha1 = fmap encodeUtf8 sha1TextMay-        , downloadInfoSha256 = fmap encodeUtf8 sha256TextMay-        }--data VersionedDownloadInfo = VersionedDownloadInfo-    { vdiVersion :: Version-    , vdiDownloadInfo :: DownloadInfo-    }-    deriving Show--instance FromJSON (WithJSONWarnings VersionedDownloadInfo) where-    parseJSON = withObjectWarnings "VersionedDownloadInfo" $ \o -> do-        version <- o ..: "version"-        downloadInfo <- parseDownloadInfoFromObject o-        return VersionedDownloadInfo-            { vdiVersion = version-            , 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 GHCDownloadInfo)-    , siGHCJSs :: Map Text (Map (CompilerVersion 'CVActual) DownloadInfo)-    , siStack :: Map Text (Map Version DownloadInfo)-    }-    deriving Show--instance FromJSON (WithJSONWarnings SetupInfo) where-    parseJSON = withObjectWarnings "SetupInfo" $ \o -> do-        siSevenzExe <- jsonSubWarningsT (o ..:? "sevenzexe-info")-        siSevenzDll <- jsonSubWarningsT (o ..:? "sevenzdll-info")-        siMsys2 <- jsonSubWarningsT (o ..:? "msys2" ..!= mempty)-        siGHCs <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty)-        siGHCJSs <- jsonSubWarningsTT (o ..:? "ghcjs" ..!= mempty)-        siStack <- jsonSubWarningsTT (o ..:? "stack" ..!= mempty)-        return SetupInfo {..}---- | For @siGHCs@ and @siGHCJSs@ fields maps are deeply merged.--- For all fields the values from the last @SetupInfo@ win.-instance Semigroup SetupInfo where-    l <> r =-        SetupInfo-        { siSevenzExe = siSevenzExe r <|> siSevenzExe l-        , siSevenzDll = siSevenzDll r <|> siSevenzDll l-        , siMsys2 = siMsys2 r <> siMsys2 l-        , siGHCs = Map.unionWith (<>) (siGHCs r) (siGHCs l)-        , siGHCJSs = Map.unionWith (<>) (siGHCJSs r) (siGHCJSs l)-        , siStack = Map.unionWith (<>) (siStack l) (siStack r) }--instance Monoid SetupInfo where-    mempty =-        SetupInfo-        { siSevenzExe = Nothing-        , siSevenzDll = Nothing-        , siMsys2 = Map.empty-        , siGHCs = Map.empty-        , siGHCJSs = Map.empty-        , siStack = Map.empty-        }-    mappend = (<>)---- | Remote or inline 'SetupInfo'-data SetupInfoLocation-    = SetupInfoFileOrURL String-    | SetupInfoInline SetupInfo-    deriving (Show)--instance FromJSON (WithJSONWarnings SetupInfoLocation) where-    parseJSON v =-        (noJSONWarnings <$>-         withText "SetupInfoFileOrURL" (pure . SetupInfoFileOrURL . T.unpack) v) <|>-        inline-      where-        inline = do-            WithJSONWarnings si w <- parseJSON v-            return $ WithJSONWarnings (SetupInfoInline si) w---- | How PVP bounds should be added to .cabal files-data PvpBoundsType-  = PvpBoundsNone-  | PvpBoundsUpper-  | PvpBoundsLower-  | PvpBoundsBoth-  deriving (Show, Read, Eq, Typeable, Ord, Enum, Bounded)--data PvpBounds = PvpBounds-  { pbType :: !PvpBoundsType-  , pbAsRevision :: !Bool-  }-  deriving (Show, Read, Eq, Typeable, Ord)--pvpBoundsText :: PvpBoundsType -> Text-pvpBoundsText PvpBoundsNone = "none"-pvpBoundsText PvpBoundsUpper = "upper"-pvpBoundsText PvpBoundsLower = "lower"-pvpBoundsText PvpBoundsBoth = "both"--parsePvpBounds :: Text -> Either String PvpBounds-parsePvpBounds t = maybe err Right $ do-    (t', asRevision) <--      case T.break (== '-') t of-        (x, "") -> Just (x, False)-        (x, "-revision") -> Just (x, True)-        _ -> Nothing-    x <- Map.lookup t' m-    Just PvpBounds-      { pbType = x-      , pbAsRevision = asRevision-      }-  where-    m = Map.fromList $ map (pvpBoundsText &&& id) [minBound..maxBound]-    err = Left $ "Invalid PVP bounds: " ++ T.unpack t--instance ToJSON PvpBounds where-  toJSON (PvpBounds typ asRevision) =-    toJSON (pvpBoundsText typ <> (if asRevision then "-revision" else ""))-instance FromJSON PvpBounds where-  parseJSON = withText "PvpBounds" (either fail return . parsePvpBounds)---- | Provide an explicit list of package dependencies when running a custom Setup.hs-explicitSetupDeps :: (MonadReader env m, HasConfig env) => PackageName -> m Bool-explicitSetupDeps name = do-    m <- view $ configL.to configExplicitSetupDeps-    return $-        -- Yes there are far cleverer ways to write this. I honestly consider-        -- the explicit pattern matching much easier to parse at a glance.-        case Map.lookup (Just name) m of-            Just b -> b-            Nothing ->-                case Map.lookup Nothing m of-                    Just b -> b-                    Nothing -> False -- default value---- | Data passed into Docker container for the Docker entrypoint's use-newtype DockerEntrypoint = DockerEntrypoint-    { deUser :: Maybe DockerUser-      -- ^ UID/GID/etc of host user, if we wish to perform UID/GID switch in container-    } deriving (Read,Show)---- | Docker host user info-data DockerUser = DockerUser-    { duUid :: UserID -- ^ uid-    , duGid :: GroupID -- ^ gid-    , duGroups :: [GroupID] -- ^ Supplemantal groups-    , duUmask :: FileMode -- ^ File creation mask }-    } deriving (Read,Show)--data GhcOptionKey-  = GOKOldEverything-  | GOKEverything-  | GOKLocals-  | GOKTargets-  | GOKPackage !PackageName-  deriving (Eq, Ord)--instance FromJSONKey GhcOptionKey where-  fromJSONKey = FromJSONKeyTextParser $ \t ->-    case t of-      "*" -> return GOKOldEverything-      "$everything" -> return GOKEverything-      "$locals" -> return GOKLocals-      "$targets" -> return GOKTargets-      _ ->-        case parsePackageName t of-          Left e -> fail $ show e-          Right x -> return $ GOKPackage x-  fromJSONKeyList = FromJSONKeyTextParser $ \_ -> fail "GhcOptionKey.fromJSONKeyList"--newtype GhcOptions = GhcOptions { unGhcOptions :: [Text] }--instance FromJSON GhcOptions where-  parseJSON = withText "GhcOptions" $ \t ->-    case parseArgs Escaping t of-      Left e -> fail e-      Right opts -> return $ GhcOptions $ map T.pack opts---------------------------------------- Lens classes---------------------------------------- | Class for environment values which have a Platform-class HasPlatform env where-    platformL :: Lens' env Platform-    default platformL :: HasConfig env => Lens' env Platform-    platformL = configL.platformL-    {-# INLINE platformL #-}-    platformVariantL :: Lens' env PlatformVariant-    default platformVariantL :: HasConfig env => Lens' env PlatformVariant-    platformVariantL = configL.platformVariantL-    {-# INLINE platformVariantL #-}---- | Class for environment values which have a GHCVariant-class HasGHCVariant env where-    ghcVariantL :: Lens' env GHCVariant-    default ghcVariantL :: HasBuildConfig env => Lens' env GHCVariant-    ghcVariantL = buildConfigL.ghcVariantL-    {-# INLINE ghcVariantL #-}---- | Class for environment values that can provide a 'Config'.-class (HasPlatform env, HasProcessContext env, HasCabalLoader env) => HasConfig env where-    configL :: Lens' env Config-    default configL :: HasBuildConfig env => Lens' env Config-    configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y })-    {-# INLINE configL #-}--class HasConfig env => HasBuildConfig env where-    buildConfigL :: Lens' env BuildConfig-    default buildConfigL :: HasEnvConfig env => Lens' env BuildConfig-    buildConfigL = envConfigL.lens-        envConfigBuildConfig-        (\x y -> x { envConfigBuildConfig = y })--class (HasBuildConfig env, HasGHCVariant env) => HasEnvConfig env where-    envConfigL :: Lens' env EnvConfig---------------------------------------- Lens instances--------------------------------------instance HasPlatform (Platform,PlatformVariant) where-    platformL = _1-    platformVariantL = _2-instance HasPlatform Config where-    platformL = lens configPlatform (\x y -> x { configPlatform = y })-    platformVariantL = lens configPlatformVariant (\x y -> x { configPlatformVariant = y })-instance HasPlatform LoadConfig-instance HasPlatform BuildConfig-instance HasPlatform EnvConfig--instance HasGHCVariant GHCVariant where-    ghcVariantL = id-    {-# INLINE ghcVariantL #-}-instance HasGHCVariant BuildConfig where-    ghcVariantL = lens bcGHCVariant (\x y -> x { bcGHCVariant = y })-instance HasGHCVariant EnvConfig--instance HasProcessContext Config where-    processContextL = runnerL.processContextL-instance HasProcessContext LoadConfig where-    processContextL = configL.processContextL-instance HasProcessContext BuildConfig where-    processContextL = configL.processContextL-instance HasProcessContext EnvConfig where-    processContextL = configL.processContextL--instance HasCabalLoader Config where-    cabalLoaderL = lens configCabalLoader (\x y -> x { configCabalLoader = y })-instance HasCabalLoader LoadConfig where-    cabalLoaderL = configL.cabalLoaderL-instance HasCabalLoader BuildConfig where-    cabalLoaderL = configL.cabalLoaderL-instance HasCabalLoader EnvConfig where-    cabalLoaderL = configL.cabalLoaderL--instance HasConfig Config where-    configL = id-    {-# INLINE configL #-}-instance HasConfig LoadConfig where-    configL = lens lcConfig (\x y -> x { lcConfig = y })-instance HasConfig BuildConfig where-    configL = lens bcConfig (\x y -> x { bcConfig = y })-instance HasConfig EnvConfig--instance HasBuildConfig BuildConfig where-    buildConfigL = id-    {-# INLINE buildConfigL #-}-instance HasBuildConfig EnvConfig--instance HasEnvConfig EnvConfig where-    envConfigL = id-    {-# INLINE envConfigL #-}--instance HasRunner Config where-  runnerL = lens configRunner (\x y -> x { configRunner = y })-instance HasRunner LoadConfig where-  runnerL = configL.runnerL-instance HasRunner BuildConfig where-  runnerL = configL.runnerL-instance HasRunner EnvConfig where-  runnerL = configL.runnerL--instance HasLogFunc Config where-  logFuncL = runnerL.logFuncL-instance HasLogFunc LoadConfig where-  logFuncL = runnerL.logFuncL-instance HasLogFunc BuildConfig where-  logFuncL = runnerL.logFuncL-instance HasLogFunc EnvConfig where-  logFuncL = runnerL.logFuncL---------------------------------------- Helper lenses--------------------------------------stackRootL :: HasCabalLoader s => Lens' s (Path Abs Dir)-stackRootL = cabalLoaderL.lens clStackRoot (\x y -> x { clStackRoot = y })---- | The compiler specified by the @SnapshotDef@. This may be--- different from the actual compiler used!-wantedCompilerVersionL :: HasBuildConfig s => Getting r s (CompilerVersion 'CVWanted)-wantedCompilerVersionL = snapshotDefL.to sdWantedCompilerVersion---- | The version of the compiler which will actually be used. May be--- different than that specified in the 'SnapshotDef' and returned--- by 'wantedCompilerVersionL'.-actualCompilerVersionL :: HasEnvConfig s => Lens' s (CompilerVersion 'CVActual)-actualCompilerVersionL = envConfigL.lens-    envConfigCompilerVersion-    (\x y -> x { envConfigCompilerVersion = y })--snapshotDefL :: HasBuildConfig s => Lens' s SnapshotDef-snapshotDefL = buildConfigL.lens-    bcSnapshotDef-    (\x y -> x { bcSnapshotDef = y })--buildOptsL :: HasConfig s => Lens' s BuildOpts-buildOptsL = configL.lens-    configBuild-    (\x y -> x { configBuild = y })--buildOptsMonoidHaddockL :: Lens' BuildOptsMonoid (Maybe Bool)-buildOptsMonoidHaddockL = lens (getFirst . buildMonoidHaddock)-                            (\buildMonoid t -> buildMonoid {buildMonoidHaddock = First t})--buildOptsMonoidTestsL :: Lens' BuildOptsMonoid (Maybe Bool)-buildOptsMonoidTestsL = lens (getFirst . buildMonoidTests)-                            (\buildMonoid t -> buildMonoid {buildMonoidTests = First t})--buildOptsMonoidBenchmarksL :: Lens' BuildOptsMonoid (Maybe Bool)-buildOptsMonoidBenchmarksL = lens (getFirst . buildMonoidBenchmarks)-                            (\buildMonoid t -> buildMonoid {buildMonoidBenchmarks = First t})--buildOptsMonoidInstallExesL :: Lens' BuildOptsMonoid (Maybe Bool)-buildOptsMonoidInstallExesL =-  lens (getFirst . buildMonoidInstallExes)-       (\buildMonoid t -> buildMonoid {buildMonoidInstallExes = First t})--buildOptsInstallExesL :: Lens' BuildOpts Bool-buildOptsInstallExesL =-  lens boptsInstallExes-       (\bopts t -> bopts {boptsInstallExes = t})--buildOptsHaddockL :: Lens' BuildOpts Bool-buildOptsHaddockL =-  lens boptsHaddock-       (\bopts t -> bopts {boptsHaddock = t})--globalOptsL :: Lens' GlobalOpts ConfigMonoid-globalOptsL = lens globalConfigMonoid (\x y -> x { globalConfigMonoid = y })--globalOptsBuildOptsMonoidL :: Lens' GlobalOpts BuildOptsMonoid-globalOptsBuildOptsMonoidL = globalOptsL.lens-    configMonoidBuildOpts-    (\x y -> x { configMonoidBuildOpts = y })--configUrlsL :: HasConfig env => Lens' env Urls-configUrlsL = configL.lens configUrls (\x y -> x { configUrls = y })--cabalVersionL :: HasEnvConfig env => Lens' env Version-cabalVersionL = envConfigL.lens-    envConfigCabalVersion-    (\x y -> x { envConfigCabalVersion = y })--loadedSnapshotL :: HasEnvConfig env => Lens' env LoadedSnapshot-loadedSnapshotL = envConfigL.lens-    envConfigLoadedSnapshot-    (\x y -> x { envConfigLoadedSnapshot = y })--whichCompilerL :: Getting r (CompilerVersion a) WhichCompiler-whichCompilerL = to whichCompiler--envOverrideSettingsL :: HasConfig env => Lens' env (EnvSettings -> IO ProcessContext)-envOverrideSettingsL = configL.lens-    configProcessContextSettings-    (\x y -> x { configProcessContextSettings = y })--globalHintsL :: HasBuildConfig s => Getting r s (Map PackageName (Maybe Version))-globalHintsL = snapshotDefL.to sdGlobalHints--shouldForceGhcColorFlag :: (HasRunner env, HasEnvConfig env)-                        => RIO env Bool-shouldForceGhcColorFlag = do-    canDoColor <- (>= $(mkVersion "8.2.1")) . getGhcVersion-              <$> view actualCompilerVersionL-    shouldDoColor <- view useColorL-    return $ canDoColor && shouldDoColor--appropriateGhcColorFlag :: (HasRunner env, HasEnvConfig env)-                        => RIO env (Maybe String)-appropriateGhcColorFlag = f <$> shouldForceGhcColorFlag-  where f True = Just ghcColorForceFlag-        f False = Nothing+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | The Config type.++module Stack.Types.Config+  (+  -- * Main configuration types and classes+  -- ** HasPlatform & HasStackRoot+   HasPlatform(..)+  ,PlatformVariant(..)+  -- ** Runner+  ,HasRunner(..)+  ,Runner(..)+  ,ColorWhen(..)+  ,terminalL+  ,reExecL+  -- ** Config & HasConfig+  ,Config(..)+  ,HasConfig(..)+  ,askLatestSnapshotUrl+  ,explicitSetupDeps+  ,configProjectRoot+  -- ** BuildConfig & HasBuildConfig+  ,BuildConfig(..)+  ,ProjectPackage(..)+  ,DepPackage(..)+  ,ppRoot+  ,ppVersion+  ,ppComponents+  ,ppGPD+  ,stackYamlL+  ,projectRootL+  ,HasBuildConfig(..)+  -- ** GHCVariant & HasGHCVariant+  ,GHCVariant(..)+  ,ghcVariantName+  ,ghcVariantSuffix+  ,parseGHCVariant+  ,HasGHCVariant(..)+  ,snapshotsDir+  -- ** EnvConfig & HasEnvConfig+  ,EnvConfig(..)+  ,HasSourceMap(..)+  ,HasEnvConfig(..)+  ,getCompilerPath+  -- * Details+  -- ** ApplyGhcOptions+  ,ApplyGhcOptions(..)+  -- ** CabalConfigKey+  ,CabalConfigKey(..)+  -- ** ConfigException+  ,HpackExecutable(..)+  ,ConfigException(..)+  -- ** ConfigMonoid+  ,ConfigMonoid(..)+  ,configMonoidInstallGHCName+  ,configMonoidSystemGHCName+  ,parseConfigMonoid+  -- ** DumpLogs+  ,DumpLogs(..)+  -- ** EnvSettings+  ,EnvSettings(..)+  ,minimalEnvSettings+  ,defaultEnvSettings+  ,plainEnvSettings+  -- ** GlobalOpts & GlobalOptsMonoid+  ,GlobalOpts(..)+  ,GlobalOptsMonoid(..)+  ,StackYamlLoc(..)+  ,stackYamlLocL+  ,LockFileBehavior(..)+  ,readLockFileBehavior+  ,lockFileBehaviorL+  ,defaultLogLevel+  -- ** Project & ProjectAndConfigMonoid+  ,Project(..)+  ,ProjectConfig(..)+  ,Curator(..)+  ,ProjectAndConfigMonoid(..)+  ,parseProjectAndConfigMonoid+  -- ** PvpBounds+  ,PvpBounds(..)+  ,PvpBoundsType(..)+  ,parsePvpBounds+  -- ** ColorWhen+  ,readColorWhen+  -- ** Styles+  ,readStyles+  -- ** SCM+  ,SCM(..)+  -- * Paths+  ,bindirSuffix+  ,GlobalInfoSource(..)+  ,getProjectWorkDir+  ,docDirSuffix+  ,extraBinDirs+  ,hpcReportDir+  ,installationRootDeps+  ,installationRootLocal+  ,bindirCompilerTools+  ,hoogleRoot+  ,hoogleDatabasePath+  ,packageDatabaseDeps+  ,packageDatabaseExtra+  ,packageDatabaseLocal+  ,platformOnlyRelDir+  ,platformGhcRelDir+  ,platformGhcVerOnlyRelDir+  ,useShaPathOnWindows+  ,shaPath+  ,shaPathForBytes+  ,workDirL+  -- * Command-specific types+  -- ** Eval+  ,EvalOpts(..)+  -- ** Exec+  ,ExecOpts(..)+  ,SpecialExecCmd(..)+  ,ExecOptsExtra(..)+  -- ** Setup+  ,DownloadInfo(..)+  ,VersionedDownloadInfo(..)+  ,GHCDownloadInfo(..)+  ,SetupInfo(..)+  ,SetupInfoLocation(..)+  -- ** Docker entrypoint+  ,DockerEntrypoint(..)+  ,DockerUser(..)+  ,module X+  -- * Lens helpers+  ,wantedCompilerVersionL+  ,actualCompilerVersionL+  ,HasCompiler(..)+  ,DumpPackage(..)+  ,CompilerPaths(..)+  ,GhcPkgExe(..)+  ,getGhcPkgExe+  ,cpWhich+  ,ExtraDirs(..)+  ,buildOptsL+  ,globalOptsL+  ,buildOptsInstallExesL+  ,buildOptsMonoidHaddockL+  ,buildOptsMonoidTestsL+  ,buildOptsMonoidBenchmarksL+  ,buildOptsMonoidInstallExesL+  ,buildOptsHaddockL+  ,globalOptsBuildOptsMonoidL+  ,stackRootL+  ,cabalVersionL+  ,whichCompilerL+  ,envOverrideSettingsL+  ,shouldForceGhcColorFlag+  ,appropriateGhcColorFlag+  -- * Lens reexport+  ,view+  ,to+  ) where++import           Control.Monad.Writer (tell)+import           Crypto.Hash (hashWith, SHA1(..))+import           Stack.Prelude+import           Pantry.Internal.AesonExtended+                 (ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object,+                  (.=), (..:), (...:), (..:?), (..!=), Value(Bool),+                  withObjectWarnings, WarningParser, Object, jsonSubWarnings,+                  jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings,+                  FromJSONKeyFunction (FromJSONKeyTextParser))+import           Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping))+import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))+import qualified Data.ByteString.Char8 as S8+import           Data.Coerce (coerce)+import           Data.List (stripPrefix)+import           Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as Map+import qualified Data.Map.Strict as M+import qualified Data.Monoid as Monoid+import           Data.Monoid.Map (MonoidMap(..))+import qualified Data.Set as Set+import qualified Data.Text as T+import           Data.Text.Encoding (encodeUtf8)+import           Data.Yaml (ParseException)+import qualified Data.Yaml as Yaml+import qualified Distribution.License as C+import           Distribution.ModuleName (ModuleName)+import           Distribution.PackageDescription (GenericPackageDescription)+import qualified Distribution.PackageDescription as C+import           Distribution.System (Platform, Arch)+import qualified Distribution.Text+import qualified Distribution.Types.UnqualComponentName as C+import           Distribution.Version (anyVersion, mkVersion', mkVersion)+import           Generics.Deriving.Monoid (memptydefault, mappenddefault)+import           Lens.Micro (Lens', lens, _1, _2, to)+import           Options.Applicative (ReadM)+import qualified Options.Applicative as OA+import qualified Options.Applicative.Types as OA+import           Pantry.Internal (Storage)+import           Path+import qualified Paths_stack as Meta+import qualified RIO.List as List+import           RIO.PrettyPrint (HasTerm (..))+import           RIO.PrettyPrint.StylesUpdate (StylesUpdate,+                     parseStylesUpdateFromString, HasStylesUpdate (..))+import           Stack.Constants+import           Stack.Types.Compiler+import           Stack.Types.CompilerBuild+import           Stack.Types.Docker+import           Stack.Types.GhcPkgId+import           Stack.Types.NamedComponent+import           Stack.Types.Nix+import           Stack.Types.Resolver+import           Stack.Types.SourceMap+import           Stack.Types.TemplateName+import           Stack.Types.Version+import qualified System.FilePath as FilePath+import           System.PosixCompat.Types (UserID, GroupID, FileMode)+import           RIO.Process (ProcessContext, HasProcessContext (..))++-- Re-exports+import           Stack.Types.Config.Build as X++-- | The base environment that almost everything in Stack runs in,+-- based off of parsing command line options in 'GlobalOpts'. Provides+-- logging and process execution.+data Runner = Runner+  { runnerGlobalOpts :: !GlobalOpts+  , runnerUseColor   :: !Bool+  , runnerLogFunc    :: !LogFunc+  , runnerTermWidth  :: !Int+  , runnerProcessContext :: !ProcessContext+  }++data ColorWhen = ColorNever | ColorAlways | ColorAuto+    deriving (Eq, Show, Generic)++instance FromJSON ColorWhen where+    parseJSON v = do+        s <- parseJSON v+        case s of+            "never"  -> return ColorNever+            "always" -> return ColorAlways+            "auto"   -> return ColorAuto+            _ -> fail ("Unknown color use: " <> s <> ". Expected values of " <>+                       "option are 'never', 'always', or 'auto'.")++-- | The top-level Stackage configuration.+data Config =+  Config {configWorkDir             :: !(Path Rel Dir)+         -- ^ this allows to override .stack-work directory+         ,configUserConfigPath      :: !(Path Abs File)+         -- ^ Path to user configuration file (usually ~/.stack/config.yaml)+         ,configBuild               :: !BuildOpts+         -- ^ Build configuration+         ,configDocker              :: !DockerOpts+         -- ^ Docker configuration+         ,configNix                 :: !NixOpts+         -- ^ Execution environment (e.g nix-shell) configuration+         ,configProcessContextSettings :: !(EnvSettings -> IO ProcessContext)+         -- ^ Environment variables to be passed to external tools+         ,configLocalProgramsBase   :: !(Path Abs Dir)+         -- ^ Non-platform-specific path containing local installations+         ,configLocalPrograms       :: !(Path Abs Dir)+         -- ^ Path containing local installations (mainly GHC)+         ,configHideTHLoading       :: !Bool+         -- ^ Hide the Template Haskell "Loading package ..." messages from the+         -- console+         ,configPlatform            :: !Platform+         -- ^ The platform we're building for, used in many directory names+         ,configPlatformVariant     :: !PlatformVariant+         -- ^ Variant of the platform, also used in directory names+         ,configGHCVariant          :: !(Maybe GHCVariant)+         -- ^ The variant of GHC requested by the user.+         ,configGHCBuild            :: !(Maybe CompilerBuild)+         -- ^ Override build of the compiler distribution (e.g. standard, gmp4, tinfo6)+         ,configLatestSnapshot      :: !Text+         -- ^ URL of a JSON file providing the latest LTS and Nightly snapshots.+         ,configSystemGHC           :: !Bool+         -- ^ Should we use the system-installed GHC (on the PATH) if+         -- available? Can be overridden by command line options.+         ,configInstallGHC          :: !Bool+         -- ^ Should we automatically install GHC if missing or the wrong+         -- version is available? Can be overridden by command line options.+         ,configSkipGHCCheck        :: !Bool+         -- ^ Don't bother checking the GHC version or architecture.+         ,configSkipMsys            :: !Bool+         -- ^ On Windows: don't use a sandboxed MSYS+         ,configCompilerCheck       :: !VersionCheck+         -- ^ Specifies which versions of the compiler are acceptable.+         ,configCompilerRepository  :: !CompilerRepository+         -- ^ Specifies the repository containing the compiler sources+         ,configLocalBin            :: !(Path Abs Dir)+         -- ^ Directory we should install executables into+         ,configRequireStackVersion :: !VersionRange+         -- ^ Require a version of stack within this range.+         ,configJobs                :: !Int+         -- ^ How many concurrent jobs to run, defaults to number of capabilities+         ,configOverrideGccPath     :: !(Maybe (Path Abs File))+         -- ^ Optional gcc override path+         ,configExtraIncludeDirs    :: ![FilePath]+         -- ^ --extra-include-dirs arguments+         ,configExtraLibDirs        :: ![FilePath]+         -- ^ --extra-lib-dirs arguments+         ,configConcurrentTests     :: !Bool+         -- ^ Run test suites concurrently+         ,configTemplateParams      :: !(Map Text Text)+         -- ^ Parameters for templates.+         ,configScmInit             :: !(Maybe SCM)+         -- ^ Initialize SCM (e.g. git) when creating new projects.+         ,configGhcOptionsByName    :: !(Map PackageName [Text])+         -- ^ Additional GHC options to apply to specific packages.+         ,configGhcOptionsByCat     :: !(Map ApplyGhcOptions [Text])+         -- ^ Additional GHC options to apply to categories of packages+         ,configCabalConfigOpts     :: !(Map CabalConfigKey [Text])+         -- ^ Additional options to be passed to ./Setup.hs configure+         ,configSetupInfoLocations  :: ![SetupInfoLocation]+         -- ^ Additional SetupInfo (inline or remote) to use to find tools.+         ,configPvpBounds           :: !PvpBounds+         -- ^ How PVP upper bounds should be added to packages+         ,configModifyCodePage      :: !Bool+         -- ^ Force the code page to UTF-8 on Windows+         ,configExplicitSetupDeps   :: !(Map (Maybe PackageName) Bool)+         -- ^ See 'explicitSetupDeps'. 'Nothing' provides the default value.+         ,configRebuildGhcOptions   :: !Bool+         -- ^ Rebuild on GHC options changes+         ,configApplyGhcOptions     :: !ApplyGhcOptions+         -- ^ Which packages to ghc-options on the command line apply to?+         ,configAllowNewer          :: !Bool+         -- ^ Ignore version ranges in .cabal files. Funny naming chosen to+         -- match cabal.+         ,configDefaultTemplate     :: !(Maybe TemplateName)+         -- ^ The default template to use when none is specified.+         -- (If Nothing, the default default is used.)+         ,configAllowDifferentUser  :: !Bool+         -- ^ Allow users other than the stack root owner to use the stack+         -- installation.+         ,configDumpLogs            :: !DumpLogs+         -- ^ Dump logs of local non-dependencies when doing a build.+         ,configProject             :: !(ProjectConfig (Project, Path Abs File))+         -- ^ Project information and stack.yaml file location+         ,configAllowLocals         :: !Bool+         -- ^ Are we allowed to build local packages? The script+         -- command disallows this.+         ,configSaveHackageCreds    :: !Bool+         -- ^ Should we save Hackage credentials to a file?+         ,configHackageBaseUrl      :: !Text+         -- ^ Hackage base URL used when uploading packages+         ,configRunner              :: !Runner+         ,configPantryConfig        :: !PantryConfig+         ,configStackRoot           :: !(Path Abs Dir)+         ,configResolver            :: !(Maybe AbstractResolver)+         -- ^ Any resolver override from the command line+         ,configStorage             :: !Storage+         -- ^ Database connection pool for Stack database+         ,configHideSourcePaths     :: !Bool+         -- ^ Enable GHC hiding source paths?+         ,configRecommendUpgrade    :: !Bool+         -- ^ Recommend a Stack upgrade?+         }++-- | The project root directory, if in a project.+configProjectRoot :: Config -> Maybe (Path Abs Dir)+configProjectRoot c =+  case configProject c of+    PCProject (_, fp) -> Just $ parent fp+    PCGlobalProject -> Nothing+    PCNoProject _deps -> Nothing++-- | Which packages do configure opts apply to?+data CabalConfigKey+  = CCKTargets -- ^ See AGOTargets+  | CCKLocals -- ^ See AGOLocals+  | CCKEverything -- ^ See AGOEverything+  | CCKPackage !PackageName -- ^ A specific package+  deriving (Show, Read, Eq, Ord)+instance FromJSON CabalConfigKey where+  parseJSON = withText "CabalConfigKey" parseCabalConfigKey+instance FromJSONKey CabalConfigKey where+  fromJSONKey = FromJSONKeyTextParser parseCabalConfigKey++parseCabalConfigKey :: Monad m => Text -> m CabalConfigKey+parseCabalConfigKey "$targets" = pure CCKTargets+parseCabalConfigKey "$locals" = pure CCKLocals+parseCabalConfigKey "$everything" = pure CCKEverything+parseCabalConfigKey name =+  case parsePackageName $ T.unpack name of+    Nothing -> fail $ "Invalid CabalConfigKey: " ++ show name+    Just x -> pure $ CCKPackage x++-- | Which packages do ghc-options on the command line apply to?+data ApplyGhcOptions = AGOTargets -- ^ all local targets+                     | AGOLocals -- ^ all local packages, even non-targets+                     | AGOEverything -- ^ every package+  deriving (Show, Read, Eq, Ord, Enum, Bounded)++instance FromJSON ApplyGhcOptions where+    parseJSON = withText "ApplyGhcOptions" $ \t ->+        case t of+            "targets" -> return AGOTargets+            "locals" -> return AGOLocals+            "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+    -- ^ include local project bin directory, GHC_PACKAGE_PATH, etc+    , esIncludeGhcPackagePath :: !Bool+    -- ^ include the GHC_PACKAGE_PATH variable+    , esStackExe :: !Bool+    -- ^ set the STACK_EXE variable to the current executable name+    , esLocaleUtf8 :: !Bool+    -- ^ set the locale to C.UTF-8+    , esKeepGhcRts :: !Bool+    -- ^ if True, keep GHCRTS variable in environment+    }+    deriving (Show, Eq, Ord)++data ExecOpts = ExecOpts+    { eoCmd :: !SpecialExecCmd+    , eoArgs :: ![String]+    , eoExtra :: !ExecOptsExtra+    } deriving (Show)++data SpecialExecCmd+    = ExecCmd String+    | ExecRun+    | ExecGhc+    | ExecRunGhc+    deriving (Show, Eq)++data ExecOptsExtra = ExecOptsExtra+  { eoEnvSettings :: !EnvSettings+  , eoPackages :: ![String]+  , eoRtsOptions :: ![String]+  , eoCwd :: !(Maybe FilePath)+  }+  deriving (Show)++data EvalOpts = EvalOpts+    { evalArg :: !String+    , evalExtra :: !ExecOptsExtra+    } deriving (Show)++-- | Parsed global command-line options.+data GlobalOpts = GlobalOpts+    { globalReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version+    , globalDockerEntrypoint :: !(Maybe DockerEntrypoint)+      -- ^ Data used when stack is acting as a Docker entrypoint (internal use only)+    , globalLogLevel     :: !LogLevel -- ^ Log level+    , globalTimeInLog    :: !Bool -- ^ Whether to include timings in logs.+    , globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'+    , globalResolver     :: !(Maybe AbstractResolver) -- ^ Resolver override+    , globalCompiler     :: !(Maybe WantedCompiler) -- ^ Compiler override+    , globalTerminal     :: !Bool -- ^ We're in a terminal?+    , globalStylesUpdate :: !StylesUpdate -- ^ SGR (Ansi) codes for styles+    , globalTermWidth    :: !(Maybe Int) -- ^ Terminal width override+    , globalStackYaml    :: !StackYamlLoc -- ^ Override project stack.yaml+    , globalLockFileBehavior :: !LockFileBehavior+    } deriving (Show)++-- | Location for the project's stack.yaml file.+data StackYamlLoc+    = SYLDefault+    -- ^ Use the standard parent-directory-checking logic+    | SYLOverride !(Path Abs File)+    -- ^ Use a specific stack.yaml file provided+    | SYLNoProject ![PackageIdentifierRevision]+    -- ^ Do not load up a project, just user configuration. Include+    -- the given extra dependencies with the resolver.+    | SYLGlobalProject+    -- ^ Do not look for a project configuration, and use the implicit global.+    deriving Show++stackYamlLocL :: HasRunner env => Lens' env StackYamlLoc+stackYamlLocL = globalOptsL.lens globalStackYaml (\x y -> x { globalStackYaml = y })++-- | How to interact with lock files+data LockFileBehavior+  = LFBReadWrite+  -- ^ Read and write lock files+  | LFBReadOnly+  -- ^ Read lock files, but do not write them+  | LFBIgnore+  -- ^ Entirely ignore lock files+  | LFBErrorOnWrite+  -- ^ Error out on trying to write a lock file. This can be used to+  -- ensure that lock files in a repository already ensure+  -- reproducible builds.+  deriving (Show, Enum, Bounded)++lockFileBehaviorL :: HasRunner env => SimpleGetter env LockFileBehavior+lockFileBehaviorL = globalOptsL.to globalLockFileBehavior++-- | Parser for 'LockFileBehavior'+readLockFileBehavior :: ReadM LockFileBehavior+readLockFileBehavior = do+  s <- OA.readerAsk+  case Map.lookup s m of+    Just x -> pure x+    Nothing -> OA.readerError $ "Invalid lock file behavior, valid options: " +++                                List.intercalate ", " (Map.keys m)+  where+    m = Map.fromList $ map (\x -> (render x, x)) [minBound..maxBound]+    render LFBReadWrite = "read-write"+    render LFBReadOnly = "read-only"+    render LFBIgnore = "ignore"+    render LFBErrorOnWrite = "error-on-write"++-- | Project configuration information. Not every run of Stack has a+-- true local project; see constructors below.+data ProjectConfig a+    = PCProject a+    -- ^ Normal run: we want a project, and have one. This comes from+    -- either 'SYLDefault' or 'SYLOverride'.+    | PCGlobalProject+    -- ^ No project was found when using 'SYLDefault'. Instead, use+    -- the implicit global.+    | PCNoProject ![PackageIdentifierRevision]+    -- ^ Use a no project run. This comes from 'SYLNoProject'.++-- | Parsed global command-line options monoid.+data GlobalOptsMonoid = GlobalOptsMonoid+    { globalMonoidReExecVersion :: !(First String) -- ^ Expected re-exec in container version+    , globalMonoidDockerEntrypoint :: !(First DockerEntrypoint)+      -- ^ Data used when stack is acting as a Docker entrypoint (internal use only)+    , globalMonoidLogLevel     :: !(First LogLevel) -- ^ Log level+    , globalMonoidTimeInLog    :: !FirstTrue -- ^ Whether to include timings in logs.+    , globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'+    , globalMonoidResolver     :: !(First (Unresolved AbstractResolver)) -- ^ Resolver override+    , globalMonoidResolverRoot :: !(First FilePath) -- ^ root directory for resolver relative path+    , globalMonoidCompiler     :: !(First WantedCompiler) -- ^ Compiler override+    , globalMonoidTerminal     :: !(First Bool) -- ^ We're in a terminal?+    , globalMonoidStyles       :: !StylesUpdate -- ^ Stack's output styles+    , globalMonoidTermWidth    :: !(First Int) -- ^ Terminal width override+    , globalMonoidStackYaml    :: !(First FilePath) -- ^ Override project stack.yaml+    , globalMonoidLockFileBehavior :: !(First LockFileBehavior) -- ^ See 'globalLockFileBehavior'+    } deriving Generic++instance Semigroup GlobalOptsMonoid where+    (<>) = mappenddefault++instance Monoid GlobalOptsMonoid where+    mempty = memptydefault+    mappend = (<>)++-- | Default logging level should be something useful but not crazy.+defaultLogLevel :: LogLevel+defaultLogLevel = LevelInfo++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'."++readStyles :: ReadM StylesUpdate+readStyles = parseStylesUpdateFromString <$> OA.readerAsk++-- | 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.+--+-- These are the components which know nothing about local configuration.+data BuildConfig = BuildConfig+    { bcConfig     :: !Config+    , bcSMWanted :: !SMWanted+    , bcExtraPackageDBs :: ![Path Abs Dir]+      -- ^ Extra package databases+    , bcStackYaml  :: !(Path Abs File)+      -- ^ Location of the stack.yaml file.+      --+      -- Note: if the STACK_YAML environment variable is used, this may be+      -- different from projectRootL </> "stack.yaml" if a different file+      -- name is used.+    , bcCurator :: !(Maybe Curator)+    }++stackYamlL :: HasBuildConfig env => Lens' env (Path Abs File)+stackYamlL = buildConfigL.lens bcStackYaml (\x y -> x { bcStackYaml = y })++-- | Directory containing the project's stack.yaml file+projectRootL :: HasBuildConfig env => Getting r env (Path Abs Dir)+projectRootL = stackYamlL.to parent++-- | Configuration after the environment has been setup.+data EnvConfig = EnvConfig+    {envConfigBuildConfig :: !BuildConfig+    ,envConfigBuildOptsCLI :: !BuildOptsCLI+    ,envConfigSourceMap :: !SourceMap+    ,envConfigSourceMapHash :: !SourceMapHash+    ,envConfigCompilerPaths :: !CompilerPaths+    }++ppGPD :: MonadIO m => ProjectPackage -> m GenericPackageDescription+ppGPD = liftIO . cpGPD . ppCommon++-- | Root directory for the given 'ProjectPackage'+ppRoot :: ProjectPackage -> Path Abs Dir+ppRoot = parent . ppCabalFP++-- | All components available in the given 'ProjectPackage'+ppComponents :: MonadIO m => ProjectPackage -> m (Set NamedComponent)+ppComponents pp = do+  gpd <- ppGPD pp+  pure $ Set.fromList $ concat+    [ maybe []  (const [CLib]) (C.condLibrary gpd)+    , go CExe   (fst <$> C.condExecutables gpd)+    , go CTest  (fst <$> C.condTestSuites gpd)+    , go CBench (fst <$> C.condBenchmarks gpd)+    ]+  where+    go :: (T.Text -> NamedComponent)+       -> [C.UnqualComponentName]+       -> [NamedComponent]+    go wrapper = map (wrapper . T.pack . C.unUnqualComponentName)++-- | Version for the given 'ProjectPackage+ppVersion :: MonadIO m => ProjectPackage -> m Version+ppVersion = fmap gpdVersion . ppGPD++-- | A project is a collection of packages. We can have multiple stack.yaml+-- files, but only one of them may contain project information.+data Project = Project+    { projectUserMsg :: !(Maybe String)+    -- ^ A warning message to display to the user when the auto generated+    -- config may have issues.+    , projectPackages :: ![RelFilePath]+    -- ^ Packages which are actually part of the project (as opposed+    -- to dependencies).+    , projectDependencies :: ![RawPackageLocation]+    -- ^ Dependencies defined within the stack.yaml file, to be+    -- applied on top of the snapshot.+    , projectFlags :: !(Map PackageName (Map FlagName Bool))+    -- ^ Flags to be applied on top of the snapshot flags.+    , projectResolver :: !RawSnapshotLocation+    -- ^ How we resolve which @Snapshot@ to use+    , projectCompiler :: !(Maybe WantedCompiler)+    -- ^ Override the compiler in 'projectResolver'+    , projectExtraPackageDBs :: ![FilePath]+    , projectCurator :: !(Maybe Curator)+    -- ^ Extra configuration intended exclusively for usage by the+    -- curator tool. In other words, this is /not/ part of the+    -- documented and exposed Stack API. SUBJECT TO CHANGE.+    , projectDropPackages :: !(Set PackageName)+    -- ^ Packages to drop from the 'projectResolver'.+    }+  deriving Show++instance ToJSON Project where+    -- Expanding the constructor fully to ensure we don't miss any fields.+    toJSON (Project userMsg packages extraDeps flags resolver mcompiler extraPackageDBs mcurator drops) = object $ concat+      [ maybe [] (\cv -> ["compiler" .= cv]) mcompiler+      , maybe [] (\msg -> ["user-message" .= msg]) userMsg+      , if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs]+      , if null extraDeps then [] else ["extra-deps" .= extraDeps]+      , if Map.null flags then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap flags)]+      , ["packages" .= packages]+      , ["resolver" .= resolver]+      , maybe [] (\c -> ["curator" .= c]) mcurator+      , if Set.null drops then [] else ["drop-packages" .= Set.map CabalString drops]+      ]++-- | Extra configuration intended exclusively for usage by the+-- curator tool. In other words, this is /not/ part of the+-- documented and exposed Stack API. SUBJECT TO CHANGE.+data Curator = Curator+  { curatorSkipTest :: !(Set PackageName)+  , curatorExpectTestFailure :: !(Set PackageName)+  , curatorSkipBenchmark :: !(Set PackageName)+  , curatorExpectBenchmarkFailure :: !(Set PackageName)+  , curatorSkipHaddock :: !(Set PackageName)+  , curatorExpectHaddockFailure :: !(Set PackageName)+  }+  deriving Show+instance ToJSON Curator where+  toJSON c = object+    [ "skip-test" .= Set.map CabalString (curatorSkipTest c)+    , "expect-test-failure" .= Set.map CabalString (curatorExpectTestFailure c)+    , "skip-bench" .= Set.map CabalString (curatorSkipBenchmark c)+    , "expect-benchmark-failure" .= Set.map CabalString (curatorExpectTestFailure c)+    , "skip-haddock" .= Set.map CabalString (curatorSkipHaddock c)+    , "expect-test-failure" .= Set.map CabalString (curatorExpectHaddockFailure c)+    ]+instance FromJSON (WithJSONWarnings Curator) where+  parseJSON = withObjectWarnings "Curator" $ \o -> Curator+    <$> fmap (Set.map unCabalString) (o ..:? "skip-test" ..!= mempty)+    <*> fmap (Set.map unCabalString) (o ..:? "expect-test-failure" ..!= mempty)+    <*> fmap (Set.map unCabalString) (o ..:? "skip-bench" ..!= mempty)+    <*> fmap (Set.map unCabalString) (o ..:? "expect-benchmark-failure" ..!= mempty)+    <*> fmap (Set.map unCabalString) (o ..:? "skip-haddock" ..!= mempty)+    <*> fmap (Set.map unCabalString) (o ..:? "expect-haddock-failure" ..!= mempty)++-- An uninterpreted representation of configuration options.+-- Configurations may be "cascaded" using mappend (left-biased).+data ConfigMonoid =+  ConfigMonoid+    { configMonoidStackRoot          :: !(First (Path Abs Dir))+    -- ^ See: 'clStackRoot'+    , configMonoidWorkDir            :: !(First (Path Rel Dir))+    -- ^ See: 'configWorkDir'.+    , configMonoidBuildOpts          :: !BuildOptsMonoid+    -- ^ build options.+    , configMonoidDockerOpts         :: !DockerOptsMonoid+    -- ^ Docker options.+    , configMonoidNixOpts            :: !NixOptsMonoid+    -- ^ Options for the execution environment (nix-shell or container)+    , configMonoidConnectionCount    :: !(First Int)+    -- ^ See: 'configConnectionCount'+    , configMonoidHideTHLoading      :: !FirstTrue+    -- ^ See: 'configHideTHLoading'+    , configMonoidLatestSnapshot     :: !(First Text)+    -- ^ See: 'configLatestSnapshot'+    , configMonoidPackageIndices     :: !(First [HackageSecurityConfig])+    -- ^ See: @picIndices@+    , configMonoidSystemGHC          :: !(First Bool)+    -- ^ See: 'configSystemGHC'+    ,configMonoidInstallGHC          :: !FirstTrue+    -- ^ See: 'configInstallGHC'+    ,configMonoidSkipGHCCheck        :: !FirstFalse+    -- ^ See: 'configSkipGHCCheck'+    ,configMonoidSkipMsys            :: !FirstFalse+    -- ^ See: 'configSkipMsys'+    ,configMonoidCompilerCheck       :: !(First VersionCheck)+    -- ^ See: 'configCompilerCheck'+    ,configMonoidCompilerRepository  :: !(First CompilerRepository)+    -- ^ See: 'configCompilerRepository'+    ,configMonoidRequireStackVersion :: !IntersectingVersionRange+    -- ^ See: 'configRequireStackVersion'+    ,configMonoidArch                :: !(First String)+    -- ^ Used for overriding the platform+    ,configMonoidGHCVariant          :: !(First GHCVariant)+    -- ^ Used for overriding the platform+    ,configMonoidGHCBuild            :: !(First CompilerBuild)+    -- ^ Used for overriding the GHC build+    ,configMonoidJobs                :: !(First Int)+    -- ^ See: 'configJobs'+    ,configMonoidExtraIncludeDirs    :: ![FilePath]+    -- ^ See: 'configExtraIncludeDirs'+    ,configMonoidExtraLibDirs        :: ![FilePath]+    -- ^ See: 'configExtraLibDirs'+    , configMonoidOverrideGccPath    :: !(First (Path Abs File))+    -- ^ Allow users to override the path to gcc+    ,configMonoidOverrideHpack       :: !(First FilePath)+    -- ^ Use Hpack executable (overrides bundled Hpack)+    ,configMonoidConcurrentTests     :: !(First Bool)+    -- ^ See: 'configConcurrentTests'+    ,configMonoidLocalBinPath        :: !(First FilePath)+    -- ^ Used to override the binary installation dir+    ,configMonoidTemplateParameters  :: !(Map Text Text)+    -- ^ Template parameters.+    ,configMonoidScmInit             :: !(First SCM)+    -- ^ Initialize SCM (e.g. git init) when making new projects?+    ,configMonoidGhcOptionsByName    :: !(MonoidMap PackageName (Monoid.Dual [Text]))+    -- ^ See 'configGhcOptionsByName'. Uses 'Monoid.Dual' so that+    -- options from the configs on the right come first, so that they+    -- can be overridden.+    ,configMonoidGhcOptionsByCat     :: !(MonoidMap ApplyGhcOptions (Monoid.Dual [Text]))+    -- ^ See 'configGhcOptionsAll'. Uses 'Monoid.Dual' so that options+    -- from the configs on the right come first, so that they can be+    -- overridden.+    ,configMonoidCabalConfigOpts     :: !(MonoidMap CabalConfigKey (Monoid.Dual [Text]))+    -- ^ See 'configCabalConfigOpts'.+    ,configMonoidExtraPath           :: ![Path Abs Dir]+    -- ^ 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      :: !FirstTrue+    -- ^ See 'configModifyCodePage'+    ,configMonoidExplicitSetupDeps   :: !(Map (Maybe PackageName) Bool)+    -- ^ See 'configExplicitSetupDeps'+    ,configMonoidRebuildGhcOptions   :: !FirstFalse+    -- ^ See 'configMonoidRebuildGhcOptions'+    ,configMonoidApplyGhcOptions     :: !(First ApplyGhcOptions)+    -- ^ See 'configApplyGhcOptions'+    ,configMonoidAllowNewer          :: !(First Bool)+    -- ^ See 'configMonoidAllowNewer'+    ,configMonoidDefaultTemplate     :: !(First TemplateName)+    -- ^ The default template to use when none is specified.+    -- (If Nothing, the default default is used.)+    , configMonoidAllowDifferentUser :: !(First Bool)+    -- ^ Allow users other than the stack root owner to use the stack+    -- installation.+    , configMonoidDumpLogs           :: !(First DumpLogs)+    -- ^ See 'configDumpLogs'+    , configMonoidSaveHackageCreds   :: !(First Bool)+    -- ^ See 'configSaveHackageCreds'+    , configMonoidHackageBaseUrl     :: !(First Text)+    -- ^ See 'configHackageBaseUrl'+    , configMonoidColorWhen          :: !(First ColorWhen)+    -- ^ When to use 'ANSI' colors+    , configMonoidStyles             :: !StylesUpdate+    , configMonoidHideSourcePaths    :: !FirstTrue+    -- ^ See 'configHideSourcePaths'+    , configMonoidRecommendUpgrade   :: !FirstTrue+    -- ^ See 'configRecommendUpgrade'+    }+  deriving (Show, Generic)++instance Semigroup ConfigMonoid where+    (<>) = mappenddefault++instance Monoid ConfigMonoid where+    mempty = memptydefault+    mappend = (<>)++parseConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ConfigMonoid)+parseConfigMonoid = withObjectWarnings "ConfigMonoid" . parseConfigMonoidObject++-- | Parse a partial configuration.  Used both to parse both a standalone config+-- file and a project file, so that a sub-parser is not required, which would interfere with+-- warnings for missing fields.+parseConfigMonoidObject :: Path Abs Dir -> Object -> WarningParser ConfigMonoid+parseConfigMonoidObject rootDir obj = do+    -- Parsing 'stackRoot' from 'stackRoot'/config.yaml would be nonsensical+    let configMonoidStackRoot = First Nothing+    configMonoidWorkDir <- First <$> obj ..:? configMonoidWorkDirName+    configMonoidBuildOpts <- jsonSubWarnings (obj ..:? configMonoidBuildOptsName ..!= mempty)+    configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty)+    configMonoidNixOpts <- jsonSubWarnings (obj ..:? configMonoidNixOptsName ..!= mempty)+    configMonoidConnectionCount <- First <$> obj ..:? configMonoidConnectionCountName+    configMonoidHideTHLoading <- FirstTrue <$> obj ..:? configMonoidHideTHLoadingName++    murls :: Maybe Value <- obj ..:? configMonoidUrlsName+    configMonoidLatestSnapshot <-+      case murls of+        Nothing -> pure $ First Nothing+        Just urls -> jsonSubWarnings $ lift $ withObjectWarnings+          "urls"+          (\o -> First <$> o ..:? "latest-snapshot" :: WarningParser (First Text))+          urls++    configMonoidPackageIndices <- First <$> jsonSubWarningsTT (obj ..:?  configMonoidPackageIndicesName)+    configMonoidSystemGHC <- First <$> obj ..:? configMonoidSystemGHCName+    configMonoidInstallGHC <- FirstTrue <$> obj ..:? configMonoidInstallGHCName+    configMonoidSkipGHCCheck <- FirstFalse <$> obj ..:? configMonoidSkipGHCCheckName+    configMonoidSkipMsys <- FirstFalse <$> obj ..:? configMonoidSkipMsysName+    configMonoidRequireStackVersion <- IntersectingVersionRange . unVersionRangeJSON <$> (+                                       obj ..:? configMonoidRequireStackVersionName+                                           ..!= VersionRangeJSON anyVersion)+    configMonoidArch <- First <$> obj ..:? configMonoidArchName+    configMonoidGHCVariant <- First <$> obj ..:? configMonoidGHCVariantName+    configMonoidGHCBuild <- First <$> obj ..:? configMonoidGHCBuildName+    configMonoidJobs <- First <$> obj ..:? configMonoidJobsName+    configMonoidExtraIncludeDirs <- map (toFilePath rootDir FilePath.</>) <$>+        obj ..:?  configMonoidExtraIncludeDirsName ..!= []+    configMonoidExtraLibDirs <- map (toFilePath rootDir FilePath.</>) <$>+        obj ..:?  configMonoidExtraLibDirsName ..!= []+    configMonoidOverrideGccPath <- First <$> obj ..:? configMonoidOverrideGccPathName+    configMonoidOverrideHpack <- First <$> obj ..:? configMonoidOverrideHpackName+    configMonoidConcurrentTests <- First <$> obj ..:? configMonoidConcurrentTestsName+    configMonoidLocalBinPath <- First <$> obj ..:? configMonoidLocalBinPathName+    templates <- obj ..:? "templates"+    (configMonoidScmInit,configMonoidTemplateParameters) <-+      case templates of+        Nothing -> return (First Nothing,M.empty)+        Just tobj -> do+          scmInit <- tobj ..:? configMonoidScmInitName+          params <- tobj ..:? configMonoidTemplateParametersName+          return (First scmInit,fromMaybe M.empty params)+    configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName+    configMonoidCompilerRepository <- First <$> (obj ..:? configMonoidCompilerRepositoryName)++    options <- Map.map unGhcOptions <$> obj ..:? configMonoidGhcOptionsName ..!= mempty++    optionsEverything <-+      case (Map.lookup GOKOldEverything options, Map.lookup GOKEverything options) of+        (Just _, Just _) -> fail "Cannot specify both `*` and `$everything` GHC options"+        (Nothing, Just x) -> return x+        (Just x, Nothing) -> do+          tell "The `*` ghc-options key is not recommended. Consider using $locals, or if really needed, $everything"+          return x+        (Nothing, Nothing) -> return []++    let configMonoidGhcOptionsByCat = coerce $ Map.fromList+          [ (AGOEverything, optionsEverything)+          , (AGOLocals, Map.findWithDefault [] GOKLocals options)+          , (AGOTargets, Map.findWithDefault [] GOKTargets options)+          ]++        configMonoidGhcOptionsByName = coerce $ Map.fromList+            [(name, opts) | (GOKPackage name, opts) <- Map.toList options]++    configMonoidCabalConfigOpts' <- obj ..:? "configure-options" ..!= mempty+    let configMonoidCabalConfigOpts = coerce (configMonoidCabalConfigOpts' :: Map CabalConfigKey [Text])++    configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= []+    configMonoidSetupInfoLocations <-+        maybeToList <$> jsonSubWarningsT (obj ..:?  configMonoidSetupInfoLocationsName)+    configMonoidLocalProgramsBase <- First <$> obj ..:? configMonoidLocalProgramsBaseName+    configMonoidPvpBounds <- First <$> obj ..:? configMonoidPvpBoundsName+    configMonoidModifyCodePage <- FirstTrue <$> obj ..:? configMonoidModifyCodePageName+    configMonoidExplicitSetupDeps <-+        (obj ..:? configMonoidExplicitSetupDepsName ..!= mempty)+        >>= fmap Map.fromList . mapM handleExplicitSetupDep . Map.toList+    configMonoidRebuildGhcOptions <- FirstFalse <$> obj ..:? configMonoidRebuildGhcOptionsName+    configMonoidApplyGhcOptions <- First <$> obj ..:? configMonoidApplyGhcOptionsName+    configMonoidAllowNewer <- First <$> obj ..:? configMonoidAllowNewerName+    configMonoidDefaultTemplate <- First <$> obj ..:? configMonoidDefaultTemplateName+    configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName+    configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName+    configMonoidSaveHackageCreds <- First <$> obj ..:? configMonoidSaveHackageCredsName+    configMonoidHackageBaseUrl <- First <$> obj ..:? configMonoidHackageBaseUrlName++    configMonoidColorWhenUS <- obj ..:? configMonoidColorWhenUSName+    configMonoidColorWhenGB <- obj ..:? configMonoidColorWhenGBName+    let configMonoidColorWhen =  First $   configMonoidColorWhenUS+                                       <|> configMonoidColorWhenGB++    configMonoidStylesUS <- obj ..:? configMonoidStylesUSName+    configMonoidStylesGB <- obj ..:? configMonoidStylesGBName+    let configMonoidStyles = fromMaybe mempty $   configMonoidStylesUS+                                              <|> configMonoidStylesGB++    configMonoidHideSourcePaths <- FirstTrue <$> obj ..:? configMonoidHideSourcePathsName+    configMonoidRecommendUpgrade <- FirstTrue <$> obj ..:? configMonoidRecommendUpgradeName++    return ConfigMonoid {..}+  where+    handleExplicitSetupDep :: Monad m => (Text, Bool) -> m (Maybe PackageName, Bool)+    handleExplicitSetupDep (name', b) = do+        name <-+            if name' == "*"+                then return Nothing+                else case parsePackageName $ T.unpack name' of+                        Nothing -> fail $ "Invalid package name: " ++ show name'+                        Just x -> return $ Just x+        return (name, b)++configMonoidWorkDirName :: Text+configMonoidWorkDirName = "work-dir"++configMonoidBuildOptsName :: Text+configMonoidBuildOptsName = "build"++configMonoidDockerOptsName :: Text+configMonoidDockerOptsName = "docker"++configMonoidNixOptsName :: Text+configMonoidNixOptsName = "nix"++configMonoidConnectionCountName :: Text+configMonoidConnectionCountName = "connection-count"++configMonoidHideTHLoadingName :: Text+configMonoidHideTHLoadingName = "hide-th-loading"++configMonoidUrlsName :: Text+configMonoidUrlsName = "urls"++configMonoidPackageIndicesName :: Text+configMonoidPackageIndicesName = "package-indices"++configMonoidSystemGHCName :: Text+configMonoidSystemGHCName = "system-ghc"++configMonoidInstallGHCName :: Text+configMonoidInstallGHCName = "install-ghc"++configMonoidSkipGHCCheckName :: Text+configMonoidSkipGHCCheckName = "skip-ghc-check"++configMonoidSkipMsysName :: Text+configMonoidSkipMsysName = "skip-msys"++configMonoidRequireStackVersionName :: Text+configMonoidRequireStackVersionName = "require-stack-version"++configMonoidArchName :: Text+configMonoidArchName = "arch"++configMonoidGHCVariantName :: Text+configMonoidGHCVariantName = "ghc-variant"++configMonoidGHCBuildName :: Text+configMonoidGHCBuildName = "ghc-build"++configMonoidJobsName :: Text+configMonoidJobsName = "jobs"++configMonoidExtraIncludeDirsName :: Text+configMonoidExtraIncludeDirsName = "extra-include-dirs"++configMonoidExtraLibDirsName :: Text+configMonoidExtraLibDirsName = "extra-lib-dirs"++configMonoidOverrideGccPathName :: Text+configMonoidOverrideGccPathName = "with-gcc"++configMonoidOverrideHpackName :: Text+configMonoidOverrideHpackName = "with-hpack"++configMonoidConcurrentTestsName :: Text+configMonoidConcurrentTestsName = "concurrent-tests"++configMonoidLocalBinPathName :: Text+configMonoidLocalBinPathName = "local-bin-path"++configMonoidScmInitName :: Text+configMonoidScmInitName = "scm-init"++configMonoidTemplateParametersName :: Text+configMonoidTemplateParametersName = "params"++configMonoidCompilerCheckName :: Text+configMonoidCompilerCheckName = "compiler-check"++configMonoidCompilerRepositoryName :: Text+configMonoidCompilerRepositoryName = "compiler-repository"++configMonoidGhcOptionsName :: Text+configMonoidGhcOptionsName = "ghc-options"++configMonoidExtraPathName :: Text+configMonoidExtraPathName = "extra-path"++configMonoidSetupInfoLocationsName :: Text+configMonoidSetupInfoLocationsName = "setup-info"++configMonoidLocalProgramsBaseName :: Text+configMonoidLocalProgramsBaseName = "local-programs-path"++configMonoidPvpBoundsName :: Text+configMonoidPvpBoundsName = "pvp-bounds"++configMonoidModifyCodePageName :: Text+configMonoidModifyCodePageName = "modify-code-page"++configMonoidExplicitSetupDepsName :: Text+configMonoidExplicitSetupDepsName = "explicit-setup-deps"++configMonoidRebuildGhcOptionsName :: Text+configMonoidRebuildGhcOptionsName = "rebuild-ghc-options"++configMonoidApplyGhcOptionsName :: Text+configMonoidApplyGhcOptionsName = "apply-ghc-options"++configMonoidAllowNewerName :: Text+configMonoidAllowNewerName = "allow-newer"++configMonoidDefaultTemplateName :: Text+configMonoidDefaultTemplateName = "default-template"++configMonoidAllowDifferentUserName :: Text+configMonoidAllowDifferentUserName = "allow-different-user"++configMonoidDumpLogsName :: Text+configMonoidDumpLogsName = "dump-logs"++configMonoidSaveHackageCredsName :: Text+configMonoidSaveHackageCredsName = "save-hackage-creds"++configMonoidHackageBaseUrlName :: Text+configMonoidHackageBaseUrlName = "hackage-base-url"++configMonoidColorWhenUSName :: Text+configMonoidColorWhenUSName = "color"++configMonoidColorWhenGBName :: Text+configMonoidColorWhenGBName = "colour"++configMonoidStylesUSName :: Text+configMonoidStylesUSName = "stack-colors"++configMonoidStylesGBName :: Text+configMonoidStylesGBName = "stack-colours"++configMonoidHideSourcePathsName :: Text+configMonoidHideSourcePathsName = "hide-source-paths"++configMonoidRecommendUpgradeName :: Text+configMonoidRecommendUpgradeName = "recommend-stack-upgrade"++data ConfigException+  = ParseConfigFileException (Path Abs File) ParseException+  | ParseCustomSnapshotException Text ParseException+  | NoProjectConfigFound (Path Abs Dir) (Maybe Text)+  | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File]+  | UnableToExtractArchive Text (Path Abs File)+  | BadStackVersionException VersionRange+  | NoMatchingSnapshot (NonEmpty SnapName)+  | ResolverMismatch !RawSnapshotLocation String+  | ResolverPartial !RawSnapshotLocation 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)+  | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC+  | NixRequiresSystemGhc+  | NoResolverWhenUsingNoProject+  | DuplicateLocalPackageNames ![(PackageName, [PackageLocation])]+  deriving Typeable+instance Show ConfigException where+    show (ParseConfigFileException configFile exception) = concat+        [ "Could not parse '"+        , toFilePath configFile+        , "':\n"+        , Yaml.prettyPrintParseException exception+        , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/"+        ]+    show (ParseCustomSnapshotException url exception) = concat+        [ "Could not parse '"+        , T.unpack url+        , "':\n"+        , Yaml.prettyPrintParseException exception+        , "\nSee https://docs.haskellstack.org/en/stable/custom_snapshot/"+        ]+    show (NoProjectConfigFound dir mcmd) = concat+        [ "Unable to find a stack.yaml file in the current directory ("+        , toFilePath dir+        , ") or its ancestors"+        , case mcmd of+            Nothing -> ""+            Just cmd -> "\nRecommended action: stack " ++ T.unpack cmd+        ]+    show (UnexpectedArchiveContents dirs files) = concat+        [ "When unpacking an archive specified in your stack.yaml file, "+        , "did not find expected contents. Expected: a single directory. Found: "+        , show ( map (toFilePath . dirname) dirs+               , map (toFilePath . filename) files+               )+        ]+    show (UnableToExtractArchive url file) = concat+        [ "Archive extraction failed. Tarballs and zip archives are supported, couldn't handle the following URL, "+        , T.unpack url, " downloaded to the file ", toFilePath $ filename file+        ]+    show (BadStackVersionException requiredRange) = concat+        [ "The version of stack you are using ("+        , show (mkVersion' Meta.version)+        , ") is outside the required\n"+        ,"version range specified in stack.yaml ("+        , T.unpack (versionRangeText requiredRange)+        , ")." ]+    show (NoMatchingSnapshot names) = concat+        [ "None of the following snapshots provides a compiler matching "+        , "your package(s):\n"+        , unlines $ map (\name -> "    - " <> T.unpack (renderSnapName name))+                        (NonEmpty.toList names)+        , resolveOptions+        ]+    show (ResolverMismatch resolver errDesc) = concat+        [ "Resolver '"+        , T.unpack $ utf8BuilderToText $ display resolver+        , "' does not have a matching compiler to build some or all of your "+        , "package(s).\n"+        , errDesc+        , resolveOptions+        ]+    show (ResolverPartial resolver errDesc) = concat+        [ "Resolver '"+        , T.unpack $ utf8BuilderToText $ display resolver+        , "' does not have all the packages to match your requirements.\n"+        , unlines $ fmap ("    " <>) (lines errDesc)+        , resolveOptions+        ]+    show (NoSuchDirectory dir) =+        "No directory could be located matching the supplied path: " ++ dir+    show (ParseGHCVariantException v) =+        "Invalid ghc-variant value: " ++ v+    show (BadStackRoot stackRoot) = concat+        [ "Invalid stack root: '"+        , toFilePath stackRoot+        , "'. Please provide a valid absolute path."+        ]+    show (Won'tCreateStackRootInDirectoryOwnedByDifferentUser envStackRoot parentDir) = concat+        [ "Preventing creation of stack root '"+        , toFilePath envStackRoot+        , "'. Parent directory '"+        , toFilePath parentDir+        , "' is owned by someone else."+        ]+    show (UserDoesn'tOwnDirectory dir) = concat+        [ "You are not the owner of '"+        , toFilePath dir+        , "'. Aborting to protect file permissions."+        , "\nRetry with '--"+        , T.unpack configMonoidAllowDifferentUserName+        , "' to disable this precaution."+        ]+    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."+        ]+    show NoResolverWhenUsingNoProject = "When using the script command, you must provide a resolver argument"+    show (DuplicateLocalPackageNames pairs) = concat+        $ "The same package name is used in multiple local packages\n"+        : map go pairs+      where+        go (name, dirs) = unlines+            $ ""+            : (packageNameString name ++ " used in:")+            : map goLoc dirs+        goLoc loc = "- " ++ show loc+instance Exception ConfigException++resolveOptions :: String+resolveOptions =+  unlines [ "\nThis may be resolved by:"+          , "    - Using '--omit-packages' to exclude mismatching package(s)."+          , "    - Using '--resolver' to specify a matching snapshot/resolver"+          ]++-- | Get the URL to request the information on the latest snapshots+askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text+askLatestSnapshotUrl = view $ configL.to configLatestSnapshot++-- | @".stack-work"@+workDirL :: HasConfig env => Lens' env (Path Rel Dir)+workDirL = configL.lens configWorkDir (\x y -> x { configWorkDir = y })++-- | Per-project work dir+getProjectWorkDir :: (HasBuildConfig env, MonadReader env m) => m (Path Abs Dir)+getProjectWorkDir = do+    root    <- view projectRootL+    workDir <- view workDirL+    return (root </> workDir)++-- | Relative directory for the platform identifier+platformOnlyRelDir+    :: (MonadReader env m, HasPlatform env, MonadThrow m)+    => m (Path Rel Dir)+platformOnlyRelDir = do+    platform <- view platformL+    platformVariant <- view platformVariantL+    parseRelDir (Distribution.Text.display platform ++ platformVariantSuffix platformVariant)++-- | Directory containing snapshots+snapshotsDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Abs Dir)+snapshotsDir = do+    root <- view stackRootL+    platform <- platformGhcRelDir+    return $ root </> relDirSnapshots </> platform++-- | Installation root for dependencies+installationRootDeps :: (HasEnvConfig env) => RIO env (Path Abs Dir)+installationRootDeps = do+    root <- view stackRootL+    -- TODO: also useShaPathOnWindows here, once #1173 is resolved.+    psc <- platformSnapAndCompilerRel+    return $ root </> relDirSnapshots </> psc++-- | Installation root for locals+installationRootLocal :: (HasEnvConfig env) => RIO env (Path Abs Dir)+installationRootLocal = do+    workDir <- getProjectWorkDir+    psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel+    return $ workDir </> relDirInstall </> psc++-- | Installation root for compiler tools+bindirCompilerTools :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)+bindirCompilerTools = do+    config <- view configL+    platform <- platformGhcRelDir+    compilerVersion <- view actualCompilerVersionL+    compiler <- parseRelDir $ compilerVersionString compilerVersion+    return $+        view stackRootL config </>+        relDirCompilerTools </>+        platform </>+        compiler </>+        bindirSuffix++-- | Hoogle directory.+hoogleRoot :: (HasEnvConfig env) => RIO env (Path Abs Dir)+hoogleRoot = do+    workDir <- getProjectWorkDir+    psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel+    return $ workDir </> relDirHoogle </> psc++-- | Get the hoogle database path.+hoogleDatabasePath :: (HasEnvConfig env) => RIO env (Path Abs File)+hoogleDatabasePath = do+    dir <- hoogleRoot+    return (dir </> relFileDatabaseHoo)++-- | Path for platform followed by snapshot name followed by compiler+-- name.+platformSnapAndCompilerRel+    :: (HasEnvConfig env)+    => RIO env (Path Rel Dir)+platformSnapAndCompilerRel = do+    platform <- platformGhcRelDir+    smh <- view $ envConfigL.to envConfigSourceMapHash+    name <- smRelDir smh+    ghc <- compilerVersionDir+    useShaPathOnWindows (platform </> name </> ghc)++-- | Relative directory for the platform and GHC identifier+platformGhcRelDir+    :: (MonadReader env m, HasEnvConfig env, MonadThrow m)+    => m (Path Rel Dir)+platformGhcRelDir = do+    cp <- view compilerPathsL+    let cbSuffix = compilerBuildSuffix $ cpBuild cp+    verOnly <- platformGhcVerOnlyRelDirStr+    parseRelDir (mconcat [ verOnly, cbSuffix ])++-- | Relative directory for the platform and GHC identifier without GHC bindist build+platformGhcVerOnlyRelDir+    :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)+    => m (Path Rel Dir)+platformGhcVerOnlyRelDir =+    parseRelDir =<< platformGhcVerOnlyRelDirStr++-- | Relative directory for the platform and GHC identifier without GHC bindist build+-- (before parsing into a Path)+platformGhcVerOnlyRelDirStr+    :: (MonadReader env m, HasPlatform env, HasGHCVariant env)+    => m FilePath+platformGhcVerOnlyRelDirStr = do+    platform <- view platformL+    platformVariant <- view platformVariantL+    ghcVariant <- view ghcVariantL+    return $ mconcat [ Distribution.Text.display platform+                     , platformVariantSuffix platformVariant+                     , ghcVariantSuffix ghcVariant ]++-- | This is an attempt to shorten stack paths on Windows to decrease our+-- chances of hitting 260 symbol path limit. The idea is to calculate+-- SHA1 hash of the path used on other architectures, encode with base+-- 16 and take first 8 symbols of it.+useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir)+useShaPathOnWindows+  | osIsWindows = shaPath+  | otherwise = pure++shaPath :: (IsPath Rel t, MonadThrow m) => Path Rel t -> m (Path Rel t)+shaPath = shaPathForBytes . encodeUtf8 . T.pack . toFilePath++shaPathForBytes :: (IsPath Rel t, MonadThrow m) => ByteString -> m (Path Rel t)+shaPathForBytes+    = parsePath . S8.unpack . S8.take 8+    . Mem.convertToBase Mem.Base16 . hashWith SHA1++-- TODO: Move something like this into the path package. Consider+-- subsuming path-io's 'AnyPath'?+class IsPath b t where+  parsePath :: MonadThrow m => FilePath -> m (Path b t)++instance IsPath Abs Dir where parsePath = parseAbsDir+instance IsPath Rel Dir where parsePath = parseRelDir+instance IsPath Abs File where parsePath = parseAbsFile+instance IsPath Rel File where parsePath = parseRelFile++compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir)+compilerVersionDir = do+    compilerVersion <- view actualCompilerVersionL+    parseRelDir $ case compilerVersion of+        ACGhc version -> versionString version+        ACGhcjs {} -> compilerVersionString compilerVersion+        ACGhcGit {} -> compilerVersionString compilerVersion++-- | Package database for installing dependencies into+packageDatabaseDeps :: (HasEnvConfig env) => RIO env (Path Abs Dir)+packageDatabaseDeps = do+    root <- installationRootDeps+    return $ root </> relDirPkgdb++-- | Package database for installing local packages into+packageDatabaseLocal :: (HasEnvConfig env) => RIO env (Path Abs Dir)+packageDatabaseLocal = do+    root <- installationRootLocal+    return $ root </> relDirPkgdb++-- | Extra package databases+packageDatabaseExtra :: (MonadReader env m, HasEnvConfig env) => m [Path Abs Dir]+packageDatabaseExtra = view $ buildConfigL.to bcExtraPackageDBs++-- | Where do we get information on global packages for loading up a+-- 'LoadedSnapshot'?+data GlobalInfoSource+  = GISSnapshotHints+  -- ^ Accept the hints in the snapshot definition+  | GISCompiler ActualCompiler+  -- ^ Look up the actual information in the installed compiler++-- | Where HPC reports and tix files get stored.+hpcReportDir :: (HasEnvConfig env)+             => RIO env (Path Abs Dir)+hpcReportDir = do+   root <- installationRootLocal+   return $ root </> relDirHpc++-- | Get the extra bin directories (for the PATH). Puts more local first+--+-- Bool indicates whether or not to include the locals+extraBinDirs :: (HasEnvConfig env)+             => RIO env (Bool -> [Path Abs Dir])+extraBinDirs = do+    deps <- installationRootDeps+    local' <- installationRootLocal+    tools <- bindirCompilerTools+    return $ \locals -> if locals+        then [local' </> bindirSuffix, deps </> bindirSuffix, tools]+        else [deps </> bindirSuffix, tools]++minimalEnvSettings :: EnvSettings+minimalEnvSettings =+    EnvSettings+    { esIncludeLocals = False+    , esIncludeGhcPackagePath = False+    , esStackExe = False+    , esLocaleUtf8 = False+    , esKeepGhcRts = False+    }++-- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH.+--+-- Note that this also passes through the GHCRTS environment variable.+-- See https://github.com/commercialhaskell/stack/issues/3444+defaultEnvSettings :: EnvSettings+defaultEnvSettings = EnvSettings+    { esIncludeLocals = True+    , esIncludeGhcPackagePath = True+    , esStackExe = True+    , esLocaleUtf8 = False+    , esKeepGhcRts = True+    }++-- | Environment settings which do not embellish the environment+--+-- Note that this also passes through the GHCRTS environment variable.+-- See https://github.com/commercialhaskell/stack/issues/3444+plainEnvSettings :: EnvSettings+plainEnvSettings = EnvSettings+    { esIncludeLocals = False+    , esIncludeGhcPackagePath = False+    , esStackExe = False+    , esLocaleUtf8 = False+    , esKeepGhcRts = True+    }++-- | Get the path for the given compiler ignoring any local binaries.+--+-- https://github.com/commercialhaskell/stack/issues/1052+getCompilerPath :: HasCompiler env => RIO env (Path Abs File)+getCompilerPath = view $ compilerPathsL.to cpCompiler++data ProjectAndConfigMonoid+  = ProjectAndConfigMonoid !Project !ConfigMonoid++parseProjectAndConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))+parseProjectAndConfigMonoid rootDir =+    withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do+        packages <- o ..:? "packages" ..!= [RelFilePath "."]+        deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= []+        flags' <- o ..:? "flags" ..!= mempty+        let flags = unCabalStringMap <$> unCabalStringMap+                    (flags' :: Map (CabalString PackageName) (Map (CabalString FlagName) Bool))++        resolver <- jsonSubWarnings $ o ...: ["snapshot", "resolver"]+        mcompiler <- o ..:? "compiler"+        msg <- o ..:? "user-message"+        config <- parseConfigMonoidObject rootDir o+        extraPackageDBs <- o ..:? "extra-package-dbs" ..!= []+        mcurator <- jsonSubWarningsT (o ..:? "curator")+        drops <- o ..:? "drop-packages" ..!= mempty+        return $ do+          deps' <- mapM (resolvePaths (Just rootDir)) deps+          resolver' <- resolvePaths (Just rootDir) resolver+          let project = Project+                  { projectUserMsg = msg+                  , projectResolver = resolver'+                  , projectCompiler = mcompiler -- FIXME make sure resolver' isn't SLCompiler+                  , projectExtraPackageDBs = extraPackageDBs+                  , projectPackages = packages+                  , projectDependencies = concatMap toList (deps' :: [NonEmpty RawPackageLocation])+                  , projectFlags = flags+                  , projectCurator = mcurator+                  , projectDropPackages = Set.map unCabalString drops+                  }+          pure $ ProjectAndConfigMonoid project config++-- | A software control system.+data SCM = Git+  deriving (Show)++instance FromJSON SCM where+    parseJSON v = do+        s <- parseJSON v+        case s of+            "git" -> return Git+            _ -> fail ("Unknown or unsupported SCM: " <> s)++instance ToJSON SCM where+    toJSON Git = toJSON ("git" :: Text)++-- | A variant of the platform, used to differentiate Docker builds from host+data PlatformVariant = PlatformVariantNone+                     | PlatformVariant String++-- | Render a platform variant to a String suffix.+platformVariantSuffix :: PlatformVariant -> String+platformVariantSuffix PlatformVariantNone = ""+platformVariantSuffix (PlatformVariant v) = "-" ++ v++-- | Specialized bariant of GHC (e.g. libgmp4 or integer-simple)+data GHCVariant+    = GHCStandard -- ^ Standard bindist+    | GHCIntegerSimple -- ^ Bindist that uses integer-simple+    | GHCCustom String -- ^ Other bindists+    deriving (Show)++instance FromJSON GHCVariant where+    -- Strange structuring is to give consistent error messages+    parseJSON =+        withText+            "GHCVariant"+            (either (fail . show) return . parseGHCVariant . T.unpack)++-- | Render a GHC variant to a String.+ghcVariantName :: GHCVariant -> String+ghcVariantName GHCStandard = "standard"+ghcVariantName GHCIntegerSimple = "integersimple"+ghcVariantName (GHCCustom name) = "custom-" ++ name++-- | Render a GHC variant to a String suffix.+ghcVariantSuffix :: GHCVariant -> String+ghcVariantSuffix GHCStandard = ""+ghcVariantSuffix v = "-" ++ ghcVariantName v++-- | Parse GHC variant from a String.+parseGHCVariant :: (MonadThrow m) => String -> m GHCVariant+parseGHCVariant s =+    case stripPrefix "custom-" s of+        Just name -> return (GHCCustom name)+        Nothing+          | s == "" -> return GHCStandard+          | s == "standard" -> return GHCStandard+          | s == "integersimple" -> return GHCIntegerSimple+          | otherwise -> return (GHCCustom s)++-- | Build of the compiler distribution (e.g. standard, gmp4, tinfo6)+-- | Information for a file to download.+data DownloadInfo = DownloadInfo+    { downloadInfoUrl :: Text+      -- ^ URL or absolute file path+    , downloadInfoContentLength :: Maybe Int+    , downloadInfoSha1 :: Maybe ByteString+    , downloadInfoSha256 :: Maybe ByteString+    } deriving (Show)++instance FromJSON (WithJSONWarnings DownloadInfo) where+    parseJSON = withObjectWarnings "DownloadInfo" parseDownloadInfoFromObject++-- | Parse JSON in existing object for 'DownloadInfo'+parseDownloadInfoFromObject :: Object -> WarningParser DownloadInfo+parseDownloadInfoFromObject o = do+    url <- o ..: "url"+    contentLength <- o ..:? "content-length"+    sha1TextMay <- o ..:? "sha1"+    sha256TextMay <- o ..:? "sha256"+    return+        DownloadInfo+        { downloadInfoUrl = url+        , downloadInfoContentLength = contentLength+        , downloadInfoSha1 = fmap encodeUtf8 sha1TextMay+        , downloadInfoSha256 = fmap encodeUtf8 sha256TextMay+        }++data VersionedDownloadInfo = VersionedDownloadInfo+    { vdiVersion :: Version+    , vdiDownloadInfo :: DownloadInfo+    }+    deriving Show++instance FromJSON (WithJSONWarnings VersionedDownloadInfo) where+    parseJSON = withObjectWarnings "VersionedDownloadInfo" $ \o -> do+        CabalString version <- o ..: "version"+        downloadInfo <- parseDownloadInfoFromObject o+        return VersionedDownloadInfo+            { vdiVersion = version+            , 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 GHCDownloadInfo)+    , siGHCJSs :: Map Text (Map ActualCompiler DownloadInfo)+    , siStack :: Map Text (Map Version DownloadInfo)+    }+    deriving Show++instance FromJSON (WithJSONWarnings SetupInfo) where+    parseJSON = withObjectWarnings "SetupInfo" $ \o -> do+        siSevenzExe <- jsonSubWarningsT (o ..:? "sevenzexe-info")+        siSevenzDll <- jsonSubWarningsT (o ..:? "sevenzdll-info")+        siMsys2 <- jsonSubWarningsT (o ..:? "msys2" ..!= mempty)+        (fmap unCabalStringMap -> siGHCs) <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty)+        siGHCJSs <- jsonSubWarningsTT (o ..:? "ghcjs" ..!= mempty)+        (fmap unCabalStringMap -> siStack) <- jsonSubWarningsTT (o ..:? "stack" ..!= mempty)+        return SetupInfo {..}++-- | For @siGHCs@ and @siGHCJSs@ fields maps are deeply merged.+-- For all fields the values from the last @SetupInfo@ win.+instance Semigroup SetupInfo where+    l <> r =+        SetupInfo+        { siSevenzExe = siSevenzExe r <|> siSevenzExe l+        , siSevenzDll = siSevenzDll r <|> siSevenzDll l+        , siMsys2 = siMsys2 r <> siMsys2 l+        , siGHCs = Map.unionWith (<>) (siGHCs r) (siGHCs l)+        , siGHCJSs = Map.unionWith (<>) (siGHCJSs r) (siGHCJSs l)+        , siStack = Map.unionWith (<>) (siStack l) (siStack r) }++instance Monoid SetupInfo where+    mempty =+        SetupInfo+        { siSevenzExe = Nothing+        , siSevenzDll = Nothing+        , siMsys2 = Map.empty+        , siGHCs = Map.empty+        , siGHCJSs = Map.empty+        , siStack = Map.empty+        }+    mappend = (<>)++-- | Remote or inline 'SetupInfo'+data SetupInfoLocation+    = SetupInfoFileOrURL String+    | SetupInfoInline SetupInfo+    deriving (Show)++instance FromJSON (WithJSONWarnings SetupInfoLocation) where+    parseJSON v =+        (noJSONWarnings <$>+         withText "SetupInfoFileOrURL" (pure . SetupInfoFileOrURL . T.unpack) v) <|>+        inline+      where+        inline = do+            WithJSONWarnings si w <- parseJSON v+            return $ WithJSONWarnings (SetupInfoInline si) w++-- | How PVP bounds should be added to .cabal files+data PvpBoundsType+  = PvpBoundsNone+  | PvpBoundsUpper+  | PvpBoundsLower+  | PvpBoundsBoth+  deriving (Show, Read, Eq, Typeable, Ord, Enum, Bounded)++data PvpBounds = PvpBounds+  { pbType :: !PvpBoundsType+  , pbAsRevision :: !Bool+  }+  deriving (Show, Read, Eq, Typeable, Ord)++pvpBoundsText :: PvpBoundsType -> Text+pvpBoundsText PvpBoundsNone = "none"+pvpBoundsText PvpBoundsUpper = "upper"+pvpBoundsText PvpBoundsLower = "lower"+pvpBoundsText PvpBoundsBoth = "both"++parsePvpBounds :: Text -> Either String PvpBounds+parsePvpBounds t = maybe err Right $ do+    (t', asRevision) <-+      case T.break (== '-') t of+        (x, "") -> Just (x, False)+        (x, "-revision") -> Just (x, True)+        _ -> Nothing+    x <- Map.lookup t' m+    Just PvpBounds+      { pbType = x+      , pbAsRevision = asRevision+      }+  where+    m = Map.fromList $ map (pvpBoundsText &&& id) [minBound..maxBound]+    err = Left $ "Invalid PVP bounds: " ++ T.unpack t++instance ToJSON PvpBounds where+  toJSON (PvpBounds typ asRevision) =+    toJSON (pvpBoundsText typ <> (if asRevision then "-revision" else ""))+instance FromJSON PvpBounds where+  parseJSON = withText "PvpBounds" (either fail return . parsePvpBounds)++-- | Provide an explicit list of package dependencies when running a custom Setup.hs+explicitSetupDeps :: (MonadReader env m, HasConfig env) => PackageName -> m Bool+explicitSetupDeps name = do+    m <- view $ configL.to configExplicitSetupDeps+    return $+        -- Yes there are far cleverer ways to write this. I honestly consider+        -- the explicit pattern matching much easier to parse at a glance.+        case Map.lookup (Just name) m of+            Just b -> b+            Nothing ->+                case Map.lookup Nothing m of+                    Just b -> b+                    Nothing -> False -- default value++-- | Data passed into Docker container for the Docker entrypoint's use+newtype DockerEntrypoint = DockerEntrypoint+    { deUser :: Maybe DockerUser+      -- ^ UID/GID/etc of host user, if we wish to perform UID/GID switch in container+    } deriving (Read,Show)++-- | Docker host user info+data DockerUser = DockerUser+    { duUid :: UserID -- ^ uid+    , duGid :: GroupID -- ^ gid+    , duGroups :: [GroupID] -- ^ Supplemantal groups+    , duUmask :: FileMode -- ^ File creation mask }+    } deriving (Read,Show)++data GhcOptionKey+  = GOKOldEverything+  | GOKEverything+  | GOKLocals+  | GOKTargets+  | GOKPackage !PackageName+  deriving (Eq, Ord)++instance FromJSONKey GhcOptionKey where+  fromJSONKey = FromJSONKeyTextParser $ \t ->+    case t of+      "*" -> return GOKOldEverything+      "$everything" -> return GOKEverything+      "$locals" -> return GOKLocals+      "$targets" -> return GOKTargets+      _ ->+        case parsePackageName $ T.unpack t of+          Nothing -> fail $ "Invalid package name: " ++ show t+          Just x -> return $ GOKPackage x+  fromJSONKeyList = FromJSONKeyTextParser $ \_ -> fail "GhcOptionKey.fromJSONKeyList"++newtype GhcOptions = GhcOptions { unGhcOptions :: [Text] }++instance FromJSON GhcOptions where+  parseJSON = withText "GhcOptions" $ \t ->+    case parseArgs Escaping t of+      Left e -> fail e+      Right opts -> return $ GhcOptions $ map T.pack opts++-----------------------------------+-- Lens classes+-----------------------------------++-- | Class for environment values which have a Platform+class HasPlatform env where+    platformL :: Lens' env Platform+    default platformL :: HasConfig env => Lens' env Platform+    platformL = configL.platformL+    {-# INLINE platformL #-}+    platformVariantL :: Lens' env PlatformVariant+    default platformVariantL :: HasConfig env => Lens' env PlatformVariant+    platformVariantL = configL.platformVariantL+    {-# INLINE platformVariantL #-}++-- | Class for environment values which have a GHCVariant+class HasGHCVariant env where+    ghcVariantL :: SimpleGetter env GHCVariant+    default ghcVariantL :: HasConfig env => SimpleGetter env GHCVariant+    ghcVariantL = configL.ghcVariantL+    {-# INLINE ghcVariantL #-}++-- | Class for environment values which have a 'Runner'.+class (HasProcessContext env, HasLogFunc env) => HasRunner env where+  runnerL :: Lens' env Runner+instance HasLogFunc Runner where+  logFuncL = lens runnerLogFunc (\x y -> x { runnerLogFunc = y })+instance HasProcessContext Runner where+  processContextL = lens runnerProcessContext (\x y -> x { runnerProcessContext = y })+instance HasRunner Runner where+  runnerL = id+instance HasStylesUpdate Runner where+  stylesUpdateL = globalOptsL.+                  lens globalStylesUpdate (\x y -> x { globalStylesUpdate = y })+instance HasTerm Runner where+  useColorL = lens runnerUseColor (\x y -> x { runnerUseColor = y })+  termWidthL = lens runnerTermWidth (\x y -> x { runnerTermWidth = y })++globalOptsL :: HasRunner env => Lens' env GlobalOpts+globalOptsL = runnerL.lens runnerGlobalOpts (\x y -> x { runnerGlobalOpts = y })++-- | Class for environment values that can provide a 'Config'.+class (HasPlatform env, HasGHCVariant env, HasProcessContext env, HasPantryConfig env, HasTerm env, HasRunner env) => HasConfig env where+    configL :: Lens' env Config+    default configL :: HasBuildConfig env => Lens' env Config+    configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y })+    {-# INLINE configL #-}++class HasConfig env => HasBuildConfig env where+    buildConfigL :: Lens' env BuildConfig+    default buildConfigL :: HasEnvConfig env => Lens' env BuildConfig+    buildConfigL = envConfigL.lens+        envConfigBuildConfig+        (\x y -> x { envConfigBuildConfig = y })++class (HasBuildConfig env, HasSourceMap env, HasCompiler env) => HasEnvConfig env where+    envConfigL :: Lens' env EnvConfig++-----------------------------------+-- Lens instances+-----------------------------------++instance HasPlatform (Platform,PlatformVariant) where+    platformL = _1+    platformVariantL = _2+instance HasPlatform Config where+    platformL = lens configPlatform (\x y -> x { configPlatform = y })+    platformVariantL = lens configPlatformVariant (\x y -> x { configPlatformVariant = y })+instance HasPlatform BuildConfig+instance HasPlatform EnvConfig++instance HasGHCVariant GHCVariant where+    ghcVariantL = id+    {-# INLINE ghcVariantL #-}+instance HasGHCVariant Config where+    ghcVariantL = to $ fromMaybe GHCStandard . configGHCVariant+instance HasGHCVariant BuildConfig+instance HasGHCVariant EnvConfig++instance HasProcessContext Config where+    processContextL = runnerL.processContextL+instance HasProcessContext BuildConfig where+    processContextL = configL.processContextL+instance HasProcessContext EnvConfig where+    processContextL = configL.processContextL++instance HasPantryConfig Config where+    pantryConfigL = lens configPantryConfig (\x y -> x { configPantryConfig = y })+instance HasPantryConfig BuildConfig where+    pantryConfigL = configL.pantryConfigL+instance HasPantryConfig EnvConfig where+    pantryConfigL = configL.pantryConfigL++instance HasConfig Config where+    configL = id+    {-# INLINE configL #-}+instance HasConfig BuildConfig where+    configL = lens bcConfig (\x y -> x { bcConfig = y })+instance HasConfig EnvConfig++instance HasBuildConfig BuildConfig where+    buildConfigL = id+    {-# INLINE buildConfigL #-}+instance HasBuildConfig EnvConfig++instance HasCompiler EnvConfig where+    compilerPathsL = to envConfigCompilerPaths+instance HasEnvConfig EnvConfig where+    envConfigL = id+    {-# INLINE envConfigL #-}++instance HasRunner Config where+  runnerL = lens configRunner (\x y -> x { configRunner = y })+instance HasRunner BuildConfig where+  runnerL = configL.runnerL+instance HasRunner EnvConfig where+  runnerL = configL.runnerL++instance HasLogFunc Config where+  logFuncL = runnerL.logFuncL+instance HasLogFunc BuildConfig where+  logFuncL = runnerL.logFuncL+instance HasLogFunc EnvConfig where+  logFuncL = runnerL.logFuncL++instance HasStylesUpdate Config where+  stylesUpdateL = runnerL.stylesUpdateL+instance HasStylesUpdate BuildConfig where+  stylesUpdateL = runnerL.stylesUpdateL+instance HasStylesUpdate EnvConfig where+  stylesUpdateL = runnerL.stylesUpdateL++instance HasTerm Config where+  useColorL = runnerL.useColorL+  termWidthL = runnerL.termWidthL+instance HasTerm BuildConfig where+  useColorL = runnerL.useColorL+  termWidthL = runnerL.termWidthL+instance HasTerm EnvConfig where+  useColorL = runnerL.useColorL+  termWidthL = runnerL.termWidthL++-----------------------------------+-- Helper lenses+-----------------------------------++stackRootL :: HasConfig s => Lens' s (Path Abs Dir)+stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y })++-- | The compiler specified by the @SnapshotDef@. This may be+-- different from the actual compiler used!+wantedCompilerVersionL :: HasBuildConfig s => Getting r s WantedCompiler+wantedCompilerVersionL = buildConfigL.to (smwCompiler . bcSMWanted)++-- | Location of the ghc-pkg executable+newtype GhcPkgExe = GhcPkgExe (Path Abs File)+  deriving Show++-- | Get the 'GhcPkgExe' from a 'HasCompiler' environment+getGhcPkgExe :: HasCompiler env => RIO env GhcPkgExe+getGhcPkgExe = view $ compilerPathsL.to cpPkg++-- | Dump information for a single package+data DumpPackage = DumpPackage+    { dpGhcPkgId :: !GhcPkgId+    , dpPackageIdent :: !PackageIdentifier+    , dpParentLibIdent :: !(Maybe PackageIdentifier)+    , dpLicense :: !(Maybe C.License)+    , dpLibDirs :: ![FilePath]+    , dpLibraries :: ![Text]+    , dpHasExposedModules :: !Bool+    , dpExposedModules :: !(Set ModuleName)+    , dpDepends :: ![GhcPkgId]+    , dpHaddockInterfaces :: ![FilePath]+    , dpHaddockHtml :: !(Maybe FilePath)+    , dpIsExposed :: !Bool+    }+    deriving (Show, Read, Eq)++-- | Paths on the filesystem for the compiler we're using+data CompilerPaths = CompilerPaths+  { cpCompilerVersion :: !ActualCompiler+  , cpArch :: !Arch+  , cpBuild :: !CompilerBuild+  , cpCompiler :: !(Path Abs File)+  -- | ghc-pkg or equivalent+  , cpPkg :: !GhcPkgExe+  -- | runghc+  , cpInterpreter :: !(Path Abs File)+  -- | haddock, in 'IO' to allow deferring the lookup+  , cpHaddock :: !(Path Abs File)+  -- | Is this a Stack-sandboxed installation?+  , cpSandboxed :: !Bool+  , cpCabalVersion :: !Version+  -- ^ This is the version of Cabal that stack will use to compile Setup.hs files+  -- in the build process.+  --+  -- Note that this is not necessarily the same version as the one that stack+  -- depends on as a library and which is displayed when running+  -- @stack ls dependencies | grep Cabal@ in the stack project.+  , cpGlobalDB :: !(Path Abs Dir)+  -- ^ Global package database+  , cpGhcInfo :: !ByteString+  -- ^ Output of @ghc --info@+  , cpGlobalDump :: !(Map PackageName DumpPackage)+  }+  deriving Show++cpWhich :: (MonadReader env m, HasCompiler env) => m WhichCompiler+cpWhich = view $ compilerPathsL.to (whichCompiler.cpCompilerVersion)++data ExtraDirs = ExtraDirs+    { edBins :: ![Path Abs Dir]+    , edInclude :: ![Path Abs Dir]+    , edLib :: ![Path Abs Dir]+    } deriving (Show, Generic)+instance Semigroup ExtraDirs where+    (<>) = mappenddefault+instance Monoid ExtraDirs where+    mempty = memptydefault+    mappend = (<>)++-- | An environment which ensures that the given compiler is available+-- on the PATH+class HasCompiler env where+  compilerPathsL :: SimpleGetter env CompilerPaths+instance HasCompiler CompilerPaths where+  compilerPathsL = id++class HasSourceMap env where+  sourceMapL :: Lens' env SourceMap+instance HasSourceMap EnvConfig where+  sourceMapL = lens envConfigSourceMap (\x y -> x { envConfigSourceMap = y })++-- | The version of the compiler which will actually be used. May be+-- different than that specified in the 'SnapshotDef' and returned+-- by 'wantedCompilerVersionL'.+actualCompilerVersionL :: HasSourceMap env => SimpleGetter env ActualCompiler+actualCompilerVersionL = sourceMapL.to smCompiler++buildOptsL :: HasConfig s => Lens' s BuildOpts+buildOptsL = configL.lens+    configBuild+    (\x y -> x { configBuild = y })++buildOptsMonoidHaddockL :: Lens' BuildOptsMonoid (Maybe Bool)+buildOptsMonoidHaddockL = lens (getFirstFalse . buildMonoidHaddock)+                            (\buildMonoid t -> buildMonoid {buildMonoidHaddock = FirstFalse t})++buildOptsMonoidTestsL :: Lens' BuildOptsMonoid (Maybe Bool)+buildOptsMonoidTestsL = lens (getFirstFalse . buildMonoidTests)+                            (\buildMonoid t -> buildMonoid {buildMonoidTests = FirstFalse t})++buildOptsMonoidBenchmarksL :: Lens' BuildOptsMonoid (Maybe Bool)+buildOptsMonoidBenchmarksL = lens (getFirstFalse . buildMonoidBenchmarks)+                            (\buildMonoid t -> buildMonoid {buildMonoidBenchmarks = FirstFalse t})++buildOptsMonoidInstallExesL :: Lens' BuildOptsMonoid (Maybe Bool)+buildOptsMonoidInstallExesL =+  lens (getFirstFalse . buildMonoidInstallExes)+       (\buildMonoid t -> buildMonoid {buildMonoidInstallExes = FirstFalse t})++buildOptsInstallExesL :: Lens' BuildOpts Bool+buildOptsInstallExesL =+  lens boptsInstallExes+       (\bopts t -> bopts {boptsInstallExes = t})++buildOptsHaddockL :: Lens' BuildOpts Bool+buildOptsHaddockL =+  lens boptsHaddock+       (\bopts t -> bopts {boptsHaddock = t})++globalOptsBuildOptsMonoidL :: Lens' GlobalOpts BuildOptsMonoid+globalOptsBuildOptsMonoidL =+  lens+    globalConfigMonoid+    (\x y -> x { globalConfigMonoid = y })+  .+  lens+    configMonoidBuildOpts+    (\x y -> x { configMonoidBuildOpts = y })++cabalVersionL :: HasCompiler env => SimpleGetter env Version+cabalVersionL = compilerPathsL.to cpCabalVersion++whichCompilerL :: Getting r ActualCompiler WhichCompiler+whichCompilerL = to whichCompiler++envOverrideSettingsL :: HasConfig env => Lens' env (EnvSettings -> IO ProcessContext)+envOverrideSettingsL = configL.lens+    configProcessContextSettings+    (\x y -> x { configProcessContextSettings = y })++shouldForceGhcColorFlag :: (HasRunner env, HasEnvConfig env)+                        => RIO env Bool+shouldForceGhcColorFlag = do+    canDoColor <- (>= mkVersion [8, 2, 1]) . getGhcVersion+              <$> view actualCompilerVersionL+    shouldDoColor <- view useColorL+    return $ canDoColor && shouldDoColor++appropriateGhcColorFlag :: (HasRunner env, HasEnvConfig env)+                        => RIO env (Maybe String)+appropriateGhcColorFlag = f <$> shouldForceGhcColorFlag+  where f True = Just ghcColorForceFlag+        f False = Nothing++-- | See 'globalTerminal'+terminalL :: HasRunner env => Lens' env Bool+terminalL = globalOptsL.lens globalTerminal (\x y -> x { globalTerminal = y })++-- | See 'globalReExecVersion'+reExecL :: HasRunner env => SimpleGetter env Bool+reExecL = globalOptsL.to (isJust . globalReExecVersion)
src/Stack/Types/Config/Build.hs view
@@ -25,15 +25,15 @@     , BenchmarkOptsMonoid(..)     , FileWatchOpts(..)     , BuildSubset(..)+    , ApplyCLIFlag (..)+    , boptsCLIFlagsByName     )     where -import           Data.Aeson.Extended+import           Pantry.Internal.AesonExtended import qualified Data.Map.Strict as Map import           Generics.Deriving.Monoid (memptydefault, mappenddefault) import           Stack.Prelude-import           Stack.Types.FlagName-import           Stack.Types.PackageName  -- | Build options that is interpreted by the build command. --   This is built up from BuildOptsCLI and BuildOptsMonoid@@ -64,7 +64,7 @@             -- ^ Watch files for changes and automatically rebuild             ,boptsKeepGoing :: !(Maybe Bool)             -- ^ Keep building/running after failure-            ,boptsKeepTmpFiles :: !(Maybe Bool)+            ,boptsKeepTmpFiles :: !Bool             -- ^ Keep intermediate files and build directories             ,boptsForceDirty :: !Bool             -- ^ Force treating all local packages as having dirty files@@ -91,36 +91,38 @@             ,boptsInterleavedOutput :: !Bool             -- ^ Should we use the interleaved GHC output when building             -- multiple packages?+            ,boptsDdumpDir :: !(Maybe Text)             }   deriving (Show)  defaultBuildOpts :: BuildOpts defaultBuildOpts = BuildOpts-    { boptsLibProfile = False-    , boptsExeProfile = False-    , boptsLibStrip = True-    , boptsExeStrip = True+    { boptsLibProfile = defaultFirstFalse buildMonoidLibProfile+    , boptsExeProfile = defaultFirstFalse buildMonoidExeProfile+    , boptsLibStrip = defaultFirstTrue buildMonoidLibStrip+    , boptsExeStrip = defaultFirstTrue buildMonoidExeStrip     , boptsHaddock = False     , boptsHaddockOpts = defaultHaddockOpts-    , boptsOpenHaddocks = False+    , boptsOpenHaddocks = defaultFirstFalse buildMonoidOpenHaddocks     , boptsHaddockDeps = Nothing-    , boptsHaddockInternal = False-    , boptsHaddockHyperlinkSource = True-    , boptsInstallExes = False-    , boptsInstallCompilerTool = False-    , boptsPreFetch = False+    , boptsHaddockInternal = defaultFirstFalse buildMonoidHaddockInternal+    , boptsHaddockHyperlinkSource = defaultFirstTrue buildMonoidHaddockHyperlinkSource+    , boptsInstallExes = defaultFirstFalse buildMonoidInstallExes+    , boptsInstallCompilerTool = defaultFirstFalse buildMonoidInstallCompilerTool+    , boptsPreFetch = defaultFirstFalse buildMonoidPreFetch     , boptsKeepGoing = Nothing-    , boptsKeepTmpFiles = Nothing-    , boptsForceDirty = False-    , boptsTests = False+    , boptsKeepTmpFiles = defaultFirstFalse buildMonoidKeepTmpFiles+    , boptsForceDirty = defaultFirstFalse buildMonoidForceDirty+    , boptsTests = defaultFirstFalse buildMonoidTests     , boptsTestOpts = defaultTestOpts-    , boptsBenchmarks = False+    , boptsBenchmarks = defaultFirstFalse buildMonoidBenchmarks     , boptsBenchmarkOpts = defaultBenchmarkOpts-    , boptsReconfigure = False-    , boptsCabalVerbose = False-    , boptsSplitObjs = False+    , boptsReconfigure = defaultFirstFalse buildMonoidReconfigure+    , boptsCabalVerbose = defaultFirstFalse buildMonoidCabalVerbose+    , boptsSplitObjs = defaultFirstFalse buildMonoidSplitObjs     , boptsSkipComponents = []-    , boptsInterleavedOutput = False+    , boptsInterleavedOutput = defaultFirstTrue buildMonoidInterleavedOutput+    , boptsDdumpDir = Nothing     }  defaultBuildOptsCLI ::BuildOptsCLI@@ -137,12 +139,31 @@     , boptsCLIInitialBuildSteps = False     } +-- | How to apply a CLI flag+data ApplyCLIFlag+  = ACFAllProjectPackages+  -- ^ Apply to all project packages which have such a flag name available.+  | ACFByName !PackageName+  -- ^ Apply to the specified package only.+  deriving (Show, Eq, Ord)++-- | Only flags set via 'ACFByName'+boptsCLIFlagsByName :: BuildOptsCLI -> Map PackageName (Map FlagName Bool)+boptsCLIFlagsByName =+  Map.fromList .+  mapMaybe go .+  Map.toList .+  boptsCLIFlags+  where+    go (ACFAllProjectPackages, _) = Nothing+    go (ACFByName name, flags) = Just (name, flags)+ -- | Build options that may only be specified from the CLI data BuildOptsCLI = BuildOptsCLI     { boptsCLITargets :: ![Text]     , boptsCLIDryrun :: !Bool     , boptsCLIGhcOptions :: ![Text]-    , boptsCLIFlags :: !(Map (Maybe PackageName) (Map FlagName Bool))+    , boptsCLIFlags :: !(Map ApplyCLIFlag (Map FlagName Bool))     , boptsCLIBuildSubset :: !BuildSubset     , boptsCLIFileWatch :: !FileWatchOpts     , boptsCLIExec :: ![(String, [String])]@@ -165,31 +186,32 @@     { buildMonoidTrace :: !Any     , buildMonoidProfile :: !Any     , buildMonoidNoStrip :: !Any-    , buildMonoidLibProfile :: !(First Bool)-    , buildMonoidExeProfile :: !(First Bool)-    , buildMonoidLibStrip :: !(First Bool)-    , buildMonoidExeStrip :: !(First Bool)-    , buildMonoidHaddock :: !(First Bool)+    , buildMonoidLibProfile :: !FirstFalse+    , buildMonoidExeProfile :: !FirstFalse+    , buildMonoidLibStrip :: !FirstTrue+    , buildMonoidExeStrip :: !FirstTrue+    , buildMonoidHaddock :: !FirstFalse     , buildMonoidHaddockOpts :: !HaddockOptsMonoid-    , buildMonoidOpenHaddocks :: !(First Bool)+    , buildMonoidOpenHaddocks :: !FirstFalse     , buildMonoidHaddockDeps :: !(First Bool)-    , buildMonoidHaddockInternal :: !(First Bool)-    , buildMonoidHaddockHyperlinkSource :: !(First Bool)-    , buildMonoidInstallExes :: !(First Bool)-    , buildMonoidInstallCompilerTool :: !(First Bool)-    , buildMonoidPreFetch :: !(First Bool)+    , buildMonoidHaddockInternal :: !FirstFalse+    , buildMonoidHaddockHyperlinkSource :: !FirstTrue+    , buildMonoidInstallExes :: !FirstFalse+    , buildMonoidInstallCompilerTool :: !FirstFalse+    , buildMonoidPreFetch :: !FirstFalse     , buildMonoidKeepGoing :: !(First Bool)-    , buildMonoidKeepTmpFiles :: !(First Bool)-    , buildMonoidForceDirty :: !(First Bool)-    , buildMonoidTests :: !(First Bool)+    , buildMonoidKeepTmpFiles :: !FirstFalse+    , buildMonoidForceDirty :: !FirstFalse+    , buildMonoidTests :: !FirstFalse     , buildMonoidTestOpts :: !TestOptsMonoid-    , buildMonoidBenchmarks :: !(First Bool)+    , buildMonoidBenchmarks :: !FirstFalse     , buildMonoidBenchmarkOpts :: !BenchmarkOptsMonoid-    , buildMonoidReconfigure :: !(First Bool)-    , buildMonoidCabalVerbose :: !(First Bool)-    , buildMonoidSplitObjs :: !(First Bool)+    , buildMonoidReconfigure :: !FirstFalse+    , buildMonoidCabalVerbose :: !FirstFalse+    , buildMonoidSplitObjs :: !FirstFalse     , buildMonoidSkipComponents :: ![Text]-    , buildMonoidInterleavedOutput :: !(First Bool)+    , buildMonoidInterleavedOutput :: !FirstTrue+    , buildMonoidDdumpDir :: !(First Text)     } deriving (Show, Generic)  instance FromJSON (WithJSONWarnings BuildOptsMonoid) where@@ -197,31 +219,32 @@     (\o -> do let buildMonoidTrace = Any False                   buildMonoidProfile = Any False                   buildMonoidNoStrip = Any False-              buildMonoidLibProfile <- First <$> o ..:? buildMonoidLibProfileArgName-              buildMonoidExeProfile <-First <$>  o ..:? buildMonoidExeProfileArgName-              buildMonoidLibStrip <- First <$> o ..:? buildMonoidLibStripArgName-              buildMonoidExeStrip <-First <$>  o ..:? buildMonoidExeStripArgName-              buildMonoidHaddock <- First <$> o ..:? buildMonoidHaddockArgName+              buildMonoidLibProfile <- FirstFalse <$> o ..:? buildMonoidLibProfileArgName+              buildMonoidExeProfile <-FirstFalse <$>  o ..:? buildMonoidExeProfileArgName+              buildMonoidLibStrip <- FirstTrue <$> o ..:? buildMonoidLibStripArgName+              buildMonoidExeStrip <-FirstTrue <$>  o ..:? buildMonoidExeStripArgName+              buildMonoidHaddock <- FirstFalse <$> o ..:? buildMonoidHaddockArgName               buildMonoidHaddockOpts <- jsonSubWarnings (o ..:? buildMonoidHaddockOptsArgName ..!= mempty)-              buildMonoidOpenHaddocks <- First <$> o ..:? buildMonoidOpenHaddocksArgName+              buildMonoidOpenHaddocks <- FirstFalse <$> o ..:? buildMonoidOpenHaddocksArgName               buildMonoidHaddockDeps <- First <$> o ..:? buildMonoidHaddockDepsArgName-              buildMonoidHaddockInternal <- First <$> o ..:? buildMonoidHaddockInternalArgName-              buildMonoidHaddockHyperlinkSource <- First <$> o ..:? buildMonoidHaddockHyperlinkSourceArgName-              buildMonoidInstallExes <- First <$> o ..:? buildMonoidInstallExesArgName-              buildMonoidInstallCompilerTool <- First <$> o ..:? buildMonoidInstallCompilerToolArgName-              buildMonoidPreFetch <- First <$> o ..:? buildMonoidPreFetchArgName+              buildMonoidHaddockInternal <- FirstFalse <$> o ..:? buildMonoidHaddockInternalArgName+              buildMonoidHaddockHyperlinkSource <- FirstTrue <$> o ..:? buildMonoidHaddockHyperlinkSourceArgName+              buildMonoidInstallExes <- FirstFalse <$> o ..:? buildMonoidInstallExesArgName+              buildMonoidInstallCompilerTool <- FirstFalse <$> o ..:? buildMonoidInstallCompilerToolArgName+              buildMonoidPreFetch <- FirstFalse <$> o ..:? buildMonoidPreFetchArgName               buildMonoidKeepGoing <- First <$> o ..:? buildMonoidKeepGoingArgName-              buildMonoidKeepTmpFiles <- First <$> o ..:? buildMonoidKeepTmpFilesArgName-              buildMonoidForceDirty <- First <$> o ..:? buildMonoidForceDirtyArgName-              buildMonoidTests <- First <$> o ..:? buildMonoidTestsArgName+              buildMonoidKeepTmpFiles <- FirstFalse <$> o ..:? buildMonoidKeepTmpFilesArgName+              buildMonoidForceDirty <- FirstFalse <$> o ..:? buildMonoidForceDirtyArgName+              buildMonoidTests <- FirstFalse <$> o ..:? buildMonoidTestsArgName               buildMonoidTestOpts <- jsonSubWarnings (o ..:? buildMonoidTestOptsArgName ..!= mempty)-              buildMonoidBenchmarks <- First <$> o ..:? buildMonoidBenchmarksArgName+              buildMonoidBenchmarks <- FirstFalse <$> o ..:? buildMonoidBenchmarksArgName               buildMonoidBenchmarkOpts <- jsonSubWarnings (o ..:? buildMonoidBenchmarkOptsArgName ..!= mempty)-              buildMonoidReconfigure <- First <$> o ..:? buildMonoidReconfigureArgName-              buildMonoidCabalVerbose <- First <$> o ..:? buildMonoidCabalVerboseArgName-              buildMonoidSplitObjs <- First <$> o ..:? buildMonoidSplitObjsName+              buildMonoidReconfigure <- FirstFalse <$> o ..:? buildMonoidReconfigureArgName+              buildMonoidCabalVerbose <- FirstFalse <$> o ..:? buildMonoidCabalVerboseArgName+              buildMonoidSplitObjs <- FirstFalse <$> o ..:? buildMonoidSplitObjsName               buildMonoidSkipComponents <- o ..:? buildMonoidSkipComponentsName ..!= mempty-              buildMonoidInterleavedOutput <- First <$> o ..:? buildMonoidInterleavedOutputName+              buildMonoidInterleavedOutput <- FirstTrue <$> o ..:? buildMonoidInterleavedOutputName+              buildMonoidDdumpDir <- o ..:? buildMonoidDdumpDirName ..!= mempty               return BuildOptsMonoid{..})  buildMonoidLibProfileArgName :: Text@@ -299,6 +322,9 @@ buildMonoidInterleavedOutputName :: Text buildMonoidInterleavedOutputName = "interleaved-output" +buildMonoidDdumpDirName :: Text+buildMonoidDdumpDirName = "ddump-dir"+ instance Semigroup BuildOptsMonoid where     (<>) = mappenddefault @@ -321,30 +347,34 @@            ,toAdditionalArgs :: ![String] -- ^ Arguments passed to the test program            ,toCoverage :: !Bool -- ^ Generate a code coverage report            ,toDisableRun :: !Bool -- ^ Disable running of tests+           ,toMaximumTimeSeconds :: !(Maybe Int) -- ^ test suite timeout in seconds            } deriving (Eq,Show)  defaultTestOpts :: TestOpts defaultTestOpts = TestOpts-    { toRerunTests = True+    { toRerunTests = defaultFirstTrue toMonoidRerunTests     , toAdditionalArgs = []-    , toCoverage = False-    , toDisableRun = False+    , toCoverage = defaultFirstFalse toMonoidCoverage+    , toDisableRun = defaultFirstFalse toMonoidDisableRun+    , toMaximumTimeSeconds = Nothing     }  data TestOptsMonoid =   TestOptsMonoid-    { toMonoidRerunTests :: !(First Bool)+    { toMonoidRerunTests :: !FirstTrue     , toMonoidAdditionalArgs :: ![String]-    , toMonoidCoverage :: !(First Bool)-    , toMonoidDisableRun :: !(First Bool)+    , toMonoidCoverage :: !FirstFalse+    , toMonoidDisableRun :: !FirstFalse+    , toMonoidMaximumTimeSeconds :: !(First (Maybe Int))     } deriving (Show, Generic)  instance FromJSON (WithJSONWarnings TestOptsMonoid) where   parseJSON = withObjectWarnings "TestOptsMonoid"-    (\o -> do toMonoidRerunTests <- First <$> o ..:? toMonoidRerunTestsArgName+    (\o -> do toMonoidRerunTests <- FirstTrue <$> o ..:? toMonoidRerunTestsArgName               toMonoidAdditionalArgs <- o ..:? toMonoidAdditionalArgsName ..!= []-              toMonoidCoverage <- First <$> o ..:? toMonoidCoverageArgName-              toMonoidDisableRun <- First <$> o ..:? toMonoidDisableRunArgName+              toMonoidCoverage <- FirstFalse <$> o ..:? toMonoidCoverageArgName+              toMonoidDisableRun <- FirstFalse <$> o ..:? toMonoidDisableRunArgName+              toMonoidMaximumTimeSeconds <- First <$> o ..:? toMonoidMaximumTimeSecondsArgName               return TestOptsMonoid{..})  toMonoidRerunTestsArgName :: Text@@ -358,6 +388,9 @@  toMonoidDisableRunArgName :: Text toMonoidDisableRunArgName = "no-run-tests"++toMonoidMaximumTimeSecondsArgName :: Text+toMonoidMaximumTimeSecondsArgName = "test-suite-timeout"  instance Semigroup TestOptsMonoid where   (<>) = mappenddefault
src/Stack/Types/Docker.hs view
@@ -10,7 +10,7 @@ module Stack.Types.Docker where  import Stack.Prelude hiding (Display (..))-import Data.Aeson.Extended+import Pantry.Internal.AesonExtended import Data.List (intercalate) import qualified Data.Text as T import Distribution.System (Platform(..), OS(..), Arch(..))@@ -18,7 +18,6 @@ import Distribution.Version (anyVersion) import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Path-import Stack.Constants import Stack.Types.Version import Text.Read (Read (..)) @@ -26,7 +25,7 @@ data DockerOpts = DockerOpts   {dockerEnable :: !Bool     -- ^ Is using Docker enabled?-  ,dockerImage :: !String+  ,dockerImage :: !(Either SomeException String)     -- ^ Exact Docker image tag or ID.  Overrides docker-repo-*/tag.   ,dockerRegistryLogin :: !Bool     -- ^ Does registry require login for pulls?@@ -48,10 +47,10 @@     -- ^ Arguments to pass directly to @docker run@.   ,dockerMount :: ![Mount]     -- ^ Volumes to mount in the container.+  ,dockerMountMode :: !(Maybe String)+    -- ^ Volume mount mode   ,dockerEnv :: ![String]     -- ^ Environment variables to set in the container.-  ,dockerDatabasePath :: !(Path Abs File)-    -- ^ Location of image usage database.   ,dockerStackExe :: !(Maybe DockerStackExe)     -- ^ Location of container-compatible stack executable   ,dockerSetUser :: !(Maybe Bool)@@ -76,11 +75,11 @@     -- ^ Optional username for Docker registry.   ,dockerMonoidRegistryPassword :: !(First String)     -- ^ Optional password for Docker registry.-  ,dockerMonoidAutoPull :: !(First Bool)+  ,dockerMonoidAutoPull :: !FirstTrue     -- ^ Automatically pull new images.-  ,dockerMonoidDetach :: !(First Bool)+  ,dockerMonoidDetach :: !FirstFalse     -- ^ Whether to run a detached container-  ,dockerMonoidPersist :: !(First Bool)+  ,dockerMonoidPersist :: !FirstFalse     -- ^ Create a persistent container (don't remove it when finished).  Implied by     -- `dockerDetach`.   ,dockerMonoidContainerName :: !(First String)@@ -90,10 +89,10 @@     -- ^ Arguments to pass directly to @docker run@   ,dockerMonoidMount :: ![Mount]     -- ^ Volumes to mount in the container+  ,dockerMonoidMountMode :: !(First String)+    -- ^ Volume mount mode   ,dockerMonoidEnv :: ![String]     -- ^ Environment variables to set in the container-  ,dockerMonoidDatabasePath :: !(First (Path Abs File))-    -- ^ Location of image usage database.   ,dockerMonoidStackExe :: !(First DockerStackExe)     -- ^ Location of container-compatible stack executable   ,dockerMonoidSetUser :: !(First Bool)@@ -115,14 +114,14 @@               dockerMonoidRegistryLogin    <- First <$> o ..:? dockerRegistryLoginArgName               dockerMonoidRegistryUsername <- First <$> o ..:? dockerRegistryUsernameArgName               dockerMonoidRegistryPassword <- First <$> o ..:? dockerRegistryPasswordArgName-              dockerMonoidAutoPull         <- First <$> o ..:? dockerAutoPullArgName-              dockerMonoidDetach           <- First <$> o ..:? dockerDetachArgName-              dockerMonoidPersist          <- First <$> o ..:? dockerPersistArgName+              dockerMonoidAutoPull         <- FirstTrue <$> o ..:? dockerAutoPullArgName+              dockerMonoidDetach           <- FirstFalse <$> o ..:? dockerDetachArgName+              dockerMonoidPersist          <- FirstFalse <$> o ..:? dockerPersistArgName               dockerMonoidContainerName    <- First <$> o ..:? dockerContainerNameArgName               dockerMonoidRunArgs          <- o ..:? dockerRunArgsArgName ..!= []               dockerMonoidMount            <- o ..:? dockerMountArgName ..!= []+              dockerMonoidMountMode        <- First <$> o ..:? dockerMountModeArgName               dockerMonoidEnv              <- o ..:? dockerEnvArgName ..!= []-              dockerMonoidDatabasePath     <- First <$> o ..:? dockerDatabasePathArgName               dockerMonoidStackExe         <- First <$> o ..:? dockerStackExeArgName               dockerMonoidSetUser          <- First <$> o ..:? dockerSetUserArgName               dockerMonoidRequireDockerVersion@@ -216,8 +215,6 @@       -- ^ @docker inspect@ failed.     | NotPulledException String       -- ^ Image does not exist.-    | InvalidCleanupCommandException String-      -- ^ Input to @docker cleanup@ has invalid command.     | InvalidImagesOutputException String       -- ^ Invalid output from @docker images@.     | InvalidPSOutputException String@@ -263,8 +260,6 @@                ,"\n\nRun '"                ,unwords [stackProgName, dockerCmdName, dockerPullCmdName]                ,"' to download it, then try again."]-    show (InvalidCleanupCommandException line) =-        concat ["Invalid line in cleanup commands: '",line,"'."]     show (InvalidImagesOutputException line) =         concat ["Invalid 'docker images' output line: '",line,"'."]     show (InvalidPSOutputException line) =@@ -385,6 +380,10 @@ dockerMountArgName :: Text dockerMountArgName = "mount" +-- | Docker mount mode argument name.+dockerMountModeArgName :: Text+dockerMountModeArgName = "mount-mode"+ -- | Docker environment variable argument name. dockerEnvArgName :: Text dockerEnvArgName = "env"@@ -397,11 +396,7 @@ dockerPersistArgName :: Text dockerPersistArgName = "persist" --- | Docker database path argument name.-dockerDatabasePathArgName :: Text-dockerDatabasePathArgName = "database-path"---- | Docker database path argument name.+-- | Docker stack executable argument name. dockerStackExeArgName :: Text dockerStackExeArgName = "stack-exe" @@ -439,10 +434,6 @@ -- | Command-line argument for @docker pull@. dockerPullCmdName :: String dockerPullCmdName = "pull"---- | Command-line argument for @docker cleanup@.-dockerCleanupCmdName :: String-dockerCleanupCmdName = "cleanup"  -- | Command-line option for @--internal-re-exec-version@. reExecArgName :: String
− src/Stack/Types/FlagName.hs 
@@ -1,118 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TupleSections #-}---- | Names for flags.--module Stack.Types.FlagName-  (FlagName-  ,FlagNameParseFail(..)-  ,flagNameParser-  ,parseFlagName-  ,parseFlagNameFromString-  ,flagNameString-  ,flagNameText-  ,fromCabalFlagName-  ,toCabalFlagName-  ,mkFlagName)-  where--import           Stack.Prelude-import           Data.Aeson.Extended-import           Data.Attoparsec.Text as A-import           Data.Char (isLetter, isDigit, toLower)-import qualified Data.Text as T-import qualified Distribution.PackageDescription as Cabal-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax---- | A parse fail.-newtype FlagNameParseFail-  = FlagNameParseFail Text-  deriving (Typeable)-instance Exception FlagNameParseFail-instance Show FlagNameParseFail where-    show (FlagNameParseFail bs) = "Invalid flag name: " ++ show bs---- | A flag name.-newtype FlagName =-  FlagName Text-  deriving (Typeable,Data,Generic,Hashable,Store,NFData,ToJSONKey)-instance Eq FlagName where-    x == y = compare x y == EQ-instance Ord FlagName where-    compare (FlagName x) (FlagName y) =-        compare (T.map toLower x) (T.map toLower y)--instance Lift FlagName where-  lift (FlagName n) =-    appE (conE 'FlagName)-         (stringE (T.unpack n))--instance Show FlagName where-  show (FlagName n) = T.unpack n--instance FromJSON FlagName where-  parseJSON j =-    do s <- parseJSON j-       case parseFlagNameFromString s of-         Nothing ->-           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 = fmap FlagName $ do-  t <- A.takeWhile1 (\c -> isAlphaNum c || separator c)-  when (T.head t == '-') $ fail "flag name cannot start with dash"-  return t-  where separator c = c == '-' || c == '_'-        isAlphaNum c = isLetter c || isDigit c---- | Make a flag name.-mkFlagName :: String -> Q Exp-mkFlagName s =-  case parseFlagNameFromString s of-    Nothing -> qRunIO $ throwString ("Invalid flag name: " ++ show s)-    Just pn -> [|pn|]---- | Convenient way to parse a flag name from a 'Text'.-parseFlagName :: MonadThrow m => Text -> m FlagName-parseFlagName x = go x-  where go =-          either (const (throwM (FlagNameParseFail x))) return .-          parseOnly (flagNameParser <* endOfInput)---- | Convenience function for parsing from a 'String'-parseFlagNameFromString :: MonadThrow m => String -> m FlagName-parseFlagNameFromString =-  parseFlagName . T.pack---- | Produce a string representation of a flag name.-flagNameString :: FlagName -> String-flagNameString (FlagName n) = T.unpack n---- | Produce a string representation of a flag name.-flagNameText :: FlagName -> Text-flagNameText (FlagName n) = n---- | Convert from a Cabal flag name.-fromCabalFlagName :: Cabal.FlagName -> FlagName-fromCabalFlagName name =-  let !x = T.pack $ Cabal.unFlagName name-  in FlagName x---- | Convert to a Cabal flag name.-toCabalFlagName :: FlagName -> Cabal.FlagName-toCabalFlagName (FlagName name) =-  let !x = T.unpack name-  in Cabal.mkFlagName x
src/Stack/Types/GhcPkgId.hs view
@@ -1,20 +1,24 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | A ghc-pkg id.  module Stack.Types.GhcPkgId   (GhcPkgId+  ,unGhcPkgId   ,ghcPkgIdParser   ,parseGhcPkgId   ,ghcPkgIdString)   where  import           Stack.Prelude-import           Data.Aeson.Extended+import           Pantry.Internal.AesonExtended import           Data.Attoparsec.Text import qualified Data.Text as T+import           Database.Persist.Sql (PersistField, PersistFieldSql)+import           Prelude (Read (..))  -- | A parse fail. newtype GhcPkgIdParseFail@@ -26,14 +30,15 @@  -- | A ghc-pkg package identifier. newtype GhcPkgId = GhcPkgId Text-  deriving (Eq,Ord,Data,Typeable,Generic)+  deriving (Eq,Ord,Data,Typeable,Generic,PersistField,PersistFieldSql)  instance Hashable GhcPkgId instance NFData GhcPkgId-instance Store GhcPkgId  instance Show GhcPkgId where   show = show . ghcPkgIdString+instance Read GhcPkgId where+  readsPrec i = map (first (GhcPkgId . T.pack)) . readsPrec i  instance FromJSON GhcPkgId where   parseJSON = withText "GhcPkgId" $ \t ->@@ -61,3 +66,7 @@ -- | Get a string representation of GHC package id. ghcPkgIdString :: GhcPkgId -> String ghcPkgIdString (GhcPkgId x) = T.unpack x++-- | Get a text value of GHC package id+unGhcPkgId :: GhcPkgId -> Text+unGhcPkgId (GhcPkgId v) = v
− src/Stack/Types/Image.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Stack.Types.Image where--import Data.Aeson.Extended-import qualified Data.Map as Map-import Generics.Deriving.Monoid (mappenddefault, memptydefault)-import Path-import Stack.Prelude---- | Image options. Currently only Docker image options.-newtype ImageOpts = ImageOpts-    { imgDockers :: [ImageDockerOpts]-      -- ^ One or more stanzas for docker image settings.-    } deriving (Show)--data ImageDockerOpts = ImageDockerOpts-    { imgDockerBase :: !(Maybe String)-      -- ^ Maybe have a docker base image name. (Although we will not-      -- be able to create any Docker images without this.)-    , imgDockerEntrypoints :: !(Maybe [String])-      -- ^ Maybe have a specific ENTRYPOINT list that will be used to-      -- create images.-    , imgDockerAdd :: !(Map FilePath (Path Abs Dir))-      -- ^ Maybe have some static project content to include in a-      -- specific directory in all the images.-    , imgDockerImageName :: !(Maybe String)-      -- ^ Maybe have a name for the image we are creating-    , imgDockerExecutables :: !(Maybe [Path Rel File])-      -- ^ Filenames of executables to add (if Nothing, add them all)-    } deriving (Show)--newtype ImageOptsMonoid = ImageOptsMonoid-    { imgMonoidDockers :: [ImageDockerOpts]-    } deriving (Show, Generic)--instance FromJSON (WithJSONWarnings ImageOptsMonoid) where-    parseJSON = withObjectWarnings-            "ImageOptsMonoid"-            (\o ->-                  do (oldDocker :: Maybe ImageDockerOpts) <- jsonSubWarningsT (o ..:? imgDockerOldArgName)-                     (dockers :: [ImageDockerOpts]) <- jsonSubWarningsT (o ..:? imgDockersArgName ..!= [])-                     let imgMonoidDockers = dockers ++ maybeToList oldDocker-                     return-                         ImageOptsMonoid-                         { ..-                         })--instance Semigroup ImageOptsMonoid where-    (<>) = mappenddefault--instance Monoid ImageOptsMonoid where-    mempty = memptydefault-    mappend = (<>)--instance FromJSON (WithJSONWarnings ImageDockerOpts) where-    parseJSON = withObjectWarnings-            "ImageDockerOpts"-            (\o ->-                  do imgDockerBase <- o ..:? imgDockerBaseArgName-                     imgDockerEntrypoints <- o ..:? imgDockerEntrypointsArgName-                     imgDockerAdd <- o ..:? imgDockerAddArgName ..!= Map.empty-                     imgDockerImageName <- o ..:? imgDockerImageNameArgName-                     imgDockerExecutables <- o ..:? imgDockerExecutablesArgName-                     return-                         ImageDockerOpts-                         { ..-                         })--imgArgName :: Text-imgArgName = "image"---- Kept for backward compatibility-imgDockerOldArgName :: Text-imgDockerOldArgName = "container"--imgDockersArgName :: Text-imgDockersArgName = "containers"--imgDockerBaseArgName :: Text-imgDockerBaseArgName = "base"--imgDockerAddArgName :: Text-imgDockerAddArgName = "add"--imgDockerEntrypointsArgName :: Text-imgDockerEntrypointsArgName = "entrypoints"--imgDockerImageNameArgName :: Text-imgDockerImageNameArgName = "name"--imgDockerExecutablesArgName :: Text-imgDockerExecutablesArgName = "executables"
src/Stack/Types/NamedComponent.hs view
@@ -16,8 +16,8 @@   , isCBench   ) where +import Pantry import Stack.Prelude-import Stack.Types.PackageName import qualified Data.Set as Set import qualified Data.Text as T @@ -41,7 +41,7 @@ renderPkgComponents = T.intercalate " " . map renderPkgComponent  renderPkgComponent :: (PackageName, NamedComponent) -> Text-renderPkgComponent (pkg, comp) = packageNameText pkg <> ":" <> renderComponent comp+renderPkgComponent (pkg, comp) = fromString (packageNameString pkg) <> ":" <> renderComponent comp  exeComponents :: Set NamedComponent -> Set Text exeComponents = Set.fromList . mapMaybe mExeName . Set.toList
src/Stack/Types/Nix.hs view
@@ -8,7 +8,7 @@  module Stack.Types.Nix where -import Data.Aeson.Extended+import Pantry.Internal.AesonExtended import Stack.Prelude import Generics.Deriving.Monoid (mappenddefault, memptydefault) @@ -43,7 +43,7 @@     -- ^ Options to be given to the nix-shell command line   ,nixMonoidPath :: !(First [Text])     -- ^ Override parts of NIX_PATH (notably 'nixpkgs')-  ,nixMonoidAddGCRoots :: !(First Bool)+  ,nixMonoidAddGCRoots :: !FirstFalse     -- ^ Should we register gc roots so running nix-collect-garbage doesn't remove nix dependencies   }   deriving (Eq, Show, Generic)@@ -57,7 +57,7 @@               nixMonoidInitFile      <- First <$> o ..:? nixInitFileArgName               nixMonoidShellOptions  <- First <$> o ..:? nixShellOptsArgName               nixMonoidPath          <- First <$> o ..:? nixPathArgName-              nixMonoidAddGCRoots    <- First <$> o ..:? nixAddGCRootsArgName+              nixMonoidAddGCRoots    <- FirstFalse <$> o ..:? nixAddGCRootsArgName               return NixOptsMonoid{..})  -- | Left-biased combine Nix options
src/Stack/Types/Package.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-}@@ -10,27 +11,22 @@ module Stack.Types.Package where  import           Stack.Prelude-import qualified Data.ByteString as S-import           Data.List+import           Foreign.C.Types (CTime)+import qualified RIO.Text as T+import           Data.Aeson (ToJSON (..), FromJSON (..), (.=), (.:), object, withObject) import qualified Data.Map as M import qualified Data.Set as Set-import           Data.Store.Version (VersionConfig)-import           Data.Store.VersionTagged (storeVersionConfig) import           Distribution.Parsec.Common (PError (..), PWarning (..), showPos) import qualified Distribution.SPDX.License as SPDX import           Distribution.License (License) import           Distribution.ModuleName (ModuleName) import           Distribution.PackageDescription (TestSuiteInterface, BuildType) import           Distribution.System (Platform (..))-import           Path as FL-import           Stack.Types.BuildPlan (PackageLocation, PackageLocationIndex (..), ExeName) import           Stack.Types.Compiler import           Stack.Types.Config-import           Stack.Types.FlagName import           Stack.Types.GhcPkgId import           Stack.Types.NamedComponent-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName+import           Stack.Types.SourceMap import           Stack.Types.Version  -- | All exceptions thrown by the library.@@ -40,9 +36,6 @@       !(Maybe Version)       ![PError]       ![PWarning]-  | PackageNoCabalFileFound (Path Abs Dir)-  | PackageMultipleCabalFilesFound (Path Abs Dir) [Path Abs File]-  | MismatchedCabalName (Path Abs File) PackageName   | MismatchedCabalIdentifier !PackageIdentifierRevision !PackageIdentifier   deriving Typeable instance Exception PackageException@@ -50,7 +43,7 @@     show (PackageInvalidCabalFile loc _mversion errs warnings) = concat         [ "Unable to parse cabal file "         , case loc of-            Left pir -> "for " ++ packageIdentifierRevisionString pir+            Left pir -> "for " ++ T.unpack (utf8BuilderToText (display pir))             Right fp -> toFilePath fp         {- @@ -80,33 +73,12 @@                 ])             warnings         ]-    show (PackageNoCabalFileFound dir) = concat-        [ "Stack looks for packages in the directories configured in"-        , " the 'packages' and 'extra-deps' fields defined in your stack.yaml\n"-        , "The current entry points to "-        , toFilePath dir-        , " but no .cabal or package.yaml file could be found there."-        ]-    show (PackageMultipleCabalFilesFound dir files) =-        "Multiple .cabal files found in directory " ++-        toFilePath dir ++-        ": " ++-        intercalate ", " (map (toFilePath . filename) files)-    show (MismatchedCabalName fp name) = concat-        [ "cabal file path "-        , toFilePath fp-        , " does not match the package name it defines.\n"-        , "Please rename the file to: "-        , packageNameString name-        , ".cabal\n"-        , "For more information, see: https://github.com/commercialhaskell/stack/issues/317"-        ]     show (MismatchedCabalIdentifier pir ident) = concat         [ "Mismatched package identifier."         , "\nFound:    "         , packageIdentifierString ident         , "\nExpected: "-        , packageIdentifierRevisionString pir+        , T.unpack $ utf8BuilderToText $ display pir         ]  -- | Libraries in a package. Since Cabal 2.0, internal libraries are a@@ -116,6 +88,10 @@   | HasLibraries !(Set Text) -- ^ the foreign library names, sub libraries get built automatically without explicit component name passing  deriving (Show,Typeable) +-- | Name of an executable.+newtype ExeName = ExeName { unExeName :: Text }+    deriving (Show, Eq, Ord, Hashable, IsString, Generic, NFData, Data, Typeable)+ -- | Some package info. data Package =   Package {packageName :: !PackageName                    -- ^ Name of the package.@@ -126,6 +102,7 @@           ,packageUnknownTools :: !(Set ExeName)          -- ^ Build tools specified in the legacy manner (build-tools:) that failed the hard-coded lookup.           ,packageAllDeps :: !(Set PackageName)           -- ^ Original dependencies (not sieved).           ,packageGhcOptions :: ![Text]                   -- ^ Ghc options used on package.+          ,packageCabalConfigOpts :: ![Text]              -- ^ Additional options passed to ./Setup.hs configure           ,packageFlags :: !(Map FlagName Bool)           -- ^ Flags used on package.           ,packageDefaultFlags :: !(Map FlagName Bool)    -- ^ Defaults for unspecified flags.           ,packageLibraries :: !PackageLibraries          -- ^ does the package have a buildable library stanza?@@ -138,9 +115,13 @@           ,packageBuildType :: !BuildType                 -- ^ Package build-type.           ,packageSetupDeps :: !(Maybe (Map PackageName VersionRange))                                                           -- ^ If present: custom-setup dependencies+          ,packageCabalSpec :: !VersionRange              -- ^ Cabal spec range           }  deriving (Show,Typeable) +packageIdent :: Package -> PackageIdentifier+packageIdent p = PackageIdentifier (packageName p) (packageVersion p)+ -- | The value for a map from dependency name. This contains both the -- version range and the type of dependency, and provides a semigroup -- instance.@@ -169,18 +150,20 @@ packageDefinedFlags :: Package -> Set FlagName packageDefinedFlags = M.keysSet . packageDefaultFlags +type InstallMap = Map PackageName (InstallLocation, Version)+ -- | Files that the package depends on, relative to package directory. -- Argument is the location of the .cabal file newtype GetPackageOpts = GetPackageOpts     { getPackageOpts :: forall env. HasEnvConfig env-                     => SourceMap+                     => InstallMap                      -> InstalledMap                      -> [PackageName]                      -> [PackageName]                      -> Path Abs File                      -> RIO env                           (Map NamedComponent (Map ModuleName (Path Abs File))-                          ,Map NamedComponent (Set DotCabalPath)+                          ,Map NamedComponent [DotCabalPath]                           ,Map NamedComponent BuildInfoOpts)     } instance Show GetPackageOpts where@@ -209,7 +192,7 @@                       => Path Abs File                       -> RIO env                            (Map NamedComponent (Map ModuleName (Path Abs File))-                           ,Map NamedComponent (Set DotCabalPath)+                           ,Map NamedComponent [DotCabalPath]                            ,Set (Path Abs File)                            ,[PackageWarning])     }@@ -234,8 +217,8 @@                 ,packageConfigEnableBenchmarks :: !Bool           -- ^ Are benchmarks enabled?                 ,packageConfigFlags :: !(Map FlagName Bool)       -- ^ Configured flags.                 ,packageConfigGhcOptions :: ![Text]               -- ^ Configured ghc options.-                ,packageConfigCompilerVersion-                                  :: !(CompilerVersion 'CVActual) -- ^ GHC version+                ,packageConfigCabalConfigOpts :: ![Text]          -- ^ ./Setup.hs configure options+                ,packageConfigCompilerVersion :: ActualCompiler   -- ^ GHC version                 ,packageConfigPlatform :: !Platform               -- ^ host platform                 }  deriving (Show,Typeable)@@ -248,28 +231,28 @@ instance Eq Package where   (==) = on (==) packageName -type SourceMap = Map PackageName PackageSource- -- | Where the package's source is located: local directory or package index data PackageSource-  = PSFiles LocalPackage InstallLocation-  -- ^ Package which exist on the filesystem (as opposed to an index tarball)-  | PSIndex InstallLocation (Map FlagName Bool) [Text] PackageIdentifierRevision-  -- ^ Package which is in an index, and the files do not exist on the-  -- filesystem yet.-    deriving Show+  = PSFilePath LocalPackage+  -- ^ Package which exist on the filesystem+  | PSRemote PackageLocationImmutable Version FromSnapshot CommonPackage+  -- ^ Package which is downloaded remotely. -piiVersion :: PackageSource -> Version-piiVersion (PSFiles lp _) = packageVersion $ lpPackage lp-piiVersion (PSIndex _ _ _ (PackageIdentifierRevision (PackageIdentifier _ v) _)) = v+instance Show PackageSource where+    show (PSFilePath lp) = concat ["PSFilePath (", show lp, ")"]+    show (PSRemote pli v fromSnapshot _) =+        concat+            [ "PSRemote"+            , "(", show pli, ")"+            , "(", show v, ")"+            , show fromSnapshot+            , "<CommonPackage>"+            ] -piiLocation :: PackageSource -> InstallLocation-piiLocation (PSFiles _ loc) = loc-piiLocation (PSIndex loc _ _ _) = loc -piiPackageLocation :: PackageSource -> PackageLocationIndex FilePath-piiPackageLocation (PSFiles lp _) = PLOther (lpLocation lp)-piiPackageLocation (PSIndex _ _ _ pir) = PLIndex pir+psVersion :: PackageSource -> Version+psVersion (PSFilePath lp) = packageVersion $ lpPackage lp+psVersion (PSRemote _ v _ _) = v  -- | Information on a locally available package of source code data LocalPackage = LocalPackage@@ -291,27 +274,52 @@     , lpTestBench     :: !(Maybe Package)     -- ^ This stores the 'Package' with tests and benchmarks enabled, if     -- either is asked for by the user.-    , lpDir           :: !(Path Abs Dir)-    -- ^ Directory of the package.     , lpCabalFile     :: !(Path Abs File)     -- ^ The .cabal file+    , lpBuildHaddocks :: !Bool     , lpForceDirty    :: !Bool-    , lpDirtyFiles    :: !(Maybe (Set FilePath))+    , lpDirtyFiles    :: !(MemoizedWith EnvConfig (Maybe (Set FilePath)))     -- ^ Nothing == not dirty, Just == dirty. Note that the Set may be empty if     -- we forced the build to treat packages as dirty. Also, the Set may not     -- include all modified files.-    , lpNewBuildCaches :: !(Map NamedComponent (Map FilePath FileCacheInfo))+    , lpNewBuildCaches :: !(MemoizedWith EnvConfig (Map NamedComponent (Map FilePath FileCacheInfo)))     -- ^ current state of the files-    , lpComponentFiles :: !(Map NamedComponent (Set (Path Abs File)))+    , lpComponentFiles :: !(MemoizedWith EnvConfig (Map NamedComponent (Set (Path Abs File))))     -- ^ all files used by this package-    , lpLocation      :: !(PackageLocation FilePath)-    -- ^ Where this source code came from     }     deriving Show -lpFiles :: LocalPackage -> Set.Set (Path Abs File)-lpFiles = Set.unions . M.elems . lpComponentFiles+newtype MemoizedWith env a = MemoizedWith { unMemoizedWith :: RIO env a }+  deriving (Functor, Applicative, Monad) +memoizeRefWith :: MonadIO m => RIO env a -> m (MemoizedWith env a)+memoizeRefWith action = do+  ref <- newIORef Nothing+  pure $ MemoizedWith $ do+    mres <- readIORef ref+    res <-+      case mres of+        Just res -> pure res+        Nothing -> do+          res <- tryAny action+          writeIORef ref $ Just res+          pure res+    either throwIO pure res++runMemoizedWith+  :: (HasEnvConfig env, MonadReader env m, MonadIO m)+  => MemoizedWith EnvConfig a+  -> m a+runMemoizedWith (MemoizedWith action) = do+  envConfig <- view envConfigL+  runRIO envConfig action++instance Show (MemoizedWith env a) where+  show _ = "<<MemoizedWith>>"++lpFiles :: HasEnvConfig env => LocalPackage -> RIO env (Set.Set (Path Abs File))+lpFiles = runMemoizedWith . fmap (Set.unions . M.elems) . lpComponentFiles+ -- | A location to install a package into, either snapshot or local data InstallLocation = Snap | Local     deriving (Show, Eq)@@ -327,23 +335,26 @@     deriving (Show, Eq)  data FileCacheInfo = FileCacheInfo-    { fciModTime :: !ModTime-    , fciSize :: !Word64-    , fciHash :: !S.ByteString+    { fciModTime :: !CTime+    , fciSize :: !FileSize+    , fciHash :: !SHA256     }-    deriving (Generic, Show, Eq, Data, Typeable)-instance Store FileCacheInfo+    deriving (Generic, Show, Eq, Typeable) instance NFData FileCacheInfo --- | Used for storage and comparison.-newtype ModTime = ModTime (Integer,Rational)-  deriving (Ord, Show, Generic, Eq, NFData, Store, Data, Typeable)--modTimeVC :: VersionConfig ModTime-modTimeVC = storeVersionConfig "mod-time-v1" "UBECpUI0JvM_SBOnRNdaiF9_yOU="--testSuccessVC :: VersionConfig Bool-testSuccessVC = storeVersionConfig "test-v1" "jC_GB0SGtbpRQbDlm7oQJP7thu8="+-- Provided for storing the BuildCache values in a file. But maybe+-- JSON/YAML isn't the right choice here, worth considering.+instance ToJSON FileCacheInfo where+  toJSON (FileCacheInfo time size hash') = object+    [ "modtime" .= time+    , "size" .= size+    , "hash" .= hash'+    ]+instance FromJSON FileCacheInfo where+  parseJSON = withObject "FileCacheInfo" $ \o -> FileCacheInfo+    <$> o .: "modtime"+    <*> o .: "size"+    <*> o .: "hash"  -- | A descriptor from a .cabal file indicating one of the following: --@@ -415,4 +426,6 @@  -- | Get the installed Version. installedVersion :: Installed -> Version-installedVersion = packageIdentifierVersion . installedPackageIdentifier+installedVersion i =+  let PackageIdentifier _ version = installedPackageIdentifier i+   in version
− src/Stack/Types/PackageDump.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Stack.Types.PackageDump-    ( InstalledCache(..)-    , InstalledCacheInner(..)-    , InstalledCacheEntry(..)-    , installedCacheVC-    ) where--import Data.Store-import Data.Store.Version-import Data.Store.VersionTagged-import Stack.Prelude-import Stack.Types.GhcPkgId-import Stack.Types.PackageIdentifier---- | Cached information on whether package have profiling libraries and haddocks.-newtype InstalledCache = InstalledCache (IORef InstalledCacheInner)-newtype InstalledCacheInner = InstalledCacheInner (Map GhcPkgId InstalledCacheEntry)-    deriving (Store, Generic, Eq, Show, Data, Typeable)---- | Cached information on whether a package has profiling libraries and haddocks.-data InstalledCacheEntry = InstalledCacheEntry-    { installedCacheProfiling :: !Bool-    , installedCacheHaddock :: !Bool-    , installedCacheSymbols :: !Bool-    , installedCacheIdent :: !PackageIdentifier }-    deriving (Eq, Generic, Show, Data, Typeable)-instance Store InstalledCacheEntry--installedCacheVC :: VersionConfig InstalledCacheInner-installedCacheVC = storeVersionConfig "installed-v1" "GGyaE6qY9FOqeWtozuadKqS7_QM="
− src/Stack/Types/PackageIdentifier.hs 
@@ -1,289 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS -fno-warn-unused-do-bind #-}---- | Package identifier (name-version).--module Stack.Types.PackageIdentifier-  ( PackageIdentifier(..)-  , PackageIdentifierRevision(..)-  , CabalHash-  , mkCabalHashFromSHA256-  , computeCabalHash-  , showCabalHash-  , CabalFileInfo(..)-  , toTuple-  , fromTuple-  , parsePackageIdentifier-  , parsePackageIdentifierFromString-  , parsePackageIdentifierRevision-  , packageIdentifierParser-  , packageIdentifierString-  , packageIdentifierRevisionString-  , packageIdentifierText-  , toCabalPackageIdentifier-  , fromCabalPackageIdentifier-  , StaticSHA256-  , mkStaticSHA256FromText-  , mkStaticSHA256FromFile-  , mkStaticSHA256FromDigest-  , staticSHA256ToText-  , staticSHA256ToBase16-  , staticSHA256ToRaw-  )-  where--import           Stack.Prelude-import           Crypto.Hash.Conduit (hashFile)-import           Crypto.Hash as Hash (hashlazy, Digest, SHA256)-import           Data.Aeson.Extended-import           Data.Attoparsec.Text as A-import qualified Data.ByteArray-import qualified Data.ByteArray.Encoding as Mem-import qualified Data.ByteString.Lazy as L-import qualified Data.Text as T-import           Data.Text.Encoding (decodeUtf8, encodeUtf8)-import qualified Distribution.Package as C-import           Stack.StaticBytes-import           Stack.Types.PackageName-import           Stack.Types.Version---- | A parse fail.-data PackageIdentifierParseFail-  = PackageIdentifierParseFail Text-  | PackageIdentifierRevisionParseFail Text-  deriving (Typeable)-instance Show PackageIdentifierParseFail where-    show (PackageIdentifierParseFail bs) = "Invalid package identifier: " ++ show bs-    show (PackageIdentifierRevisionParseFail bs) = "Invalid package identifier (with optional revision): " ++ show bs-instance Exception PackageIdentifierParseFail---- | A pkg-ver combination.-data PackageIdentifier = PackageIdentifier-  { -- | Get the name part of the identifier.-    packageIdentifierName    :: !PackageName-    -- | Get the version part of the identifier.-  , packageIdentifierVersion :: !Version-  } deriving (Eq,Ord,Generic,Data,Typeable)--instance NFData PackageIdentifier where-  rnf (PackageIdentifier !p !v) =-      seq (rnf p) (rnf v)--instance Hashable PackageIdentifier-instance Store PackageIdentifier--instance Show PackageIdentifier where-  show = show . packageIdentifierString-instance Display PackageIdentifier where-  display = fromString . packageIdentifierString--instance ToJSON PackageIdentifier where-  toJSON = toJSON . packageIdentifierString-instance FromJSON PackageIdentifier where-  parseJSON = withText "PackageIdentifier" $ \t ->-    case parsePackageIdentifier t of-      Left e -> fail $ show (e, t)-      Right x -> return x---- | A 'PackageIdentifier' combined with optionally specified Hackage--- cabal file revision.-data PackageIdentifierRevision = PackageIdentifierRevision-  { pirIdent :: !PackageIdentifier-  , pirRevision :: !CabalFileInfo-  } deriving (Eq,Ord,Generic,Data,Typeable)--instance NFData PackageIdentifierRevision where-  rnf (PackageIdentifierRevision !i !c) =-      seq (rnf i) (rnf c)--instance Hashable PackageIdentifierRevision-instance Store PackageIdentifierRevision--instance Show PackageIdentifierRevision where-  show = show . packageIdentifierRevisionString--instance ToJSON PackageIdentifierRevision where-  toJSON = toJSON . packageIdentifierRevisionString-instance FromJSON PackageIdentifierRevision where-  parseJSON = withText "PackageIdentifierRevision" $ \t ->-    case parsePackageIdentifierRevision t of-      Left e -> fail $ show (e, t)-      Right x -> return x---- | A cryptographic hash of a Cabal file.-newtype CabalHash = CabalHash { unCabalHash :: StaticSHA256 }-    deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Store, Hashable)---- | A SHA256 hash, stored in a static size for more efficient--- serialization with store.-newtype StaticSHA256 = StaticSHA256 Bytes32-    deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store)---- | Generate a 'StaticSHA256' value from a base16-encoded SHA256 hash.-mkStaticSHA256FromText :: Text -> Either SomeException StaticSHA256-mkStaticSHA256FromText t =-  mapLeft (toException . stringException) (Mem.convertFromBase Mem.Base16 (encodeUtf8 t))-  >>= either (Left . toE) (Right . StaticSHA256)-    . toStaticExact-    . (id :: ByteString -> ByteString)-  where-    toE e = toException $ stringException $ concat-      [ "Unable to convert "-      , show t-      , " into SHA256: "-      , show e-      ]---- | Generate a 'StaticSHA256' value from the contents of a file.-mkStaticSHA256FromFile :: MonadIO m => Path Abs File -> m StaticSHA256-mkStaticSHA256FromFile fp = liftIO $ mkStaticSHA256FromDigest <$> hashFile (toFilePath fp)--mkStaticSHA256FromDigest :: Hash.Digest Hash.SHA256 -> StaticSHA256-mkStaticSHA256FromDigest digest-  = StaticSHA256-  $ either impureThrow id-  $ toStaticExact-    (Data.ByteArray.convert digest :: ByteString)---- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash.-staticSHA256ToText :: StaticSHA256 -> Text-staticSHA256ToText = decodeUtf8 . staticSHA256ToBase16---- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash.-staticSHA256ToBase16 :: StaticSHA256 -> ByteString-staticSHA256ToBase16 (StaticSHA256 x) = Mem.convertToBase Mem.Base16 x--staticSHA256ToRaw :: StaticSHA256 -> ByteString-staticSHA256ToRaw (StaticSHA256 x) = Data.ByteArray.convert x---- | Generate a 'CabalHash' value from a base16-encoded SHA256 hash.-mkCabalHashFromSHA256 :: Text -> Either SomeException CabalHash-mkCabalHashFromSHA256 = fmap CabalHash . mkStaticSHA256FromText---- | Convert a 'CabalHash' into a base16-encoded SHA256 hash.-cabalHashToText :: CabalHash -> Text-cabalHashToText = staticSHA256ToText . unCabalHash---- | Compute a 'CabalHash' value from a cabal file's contents.-computeCabalHash :: L.ByteString -> CabalHash-computeCabalHash = CabalHash . mkStaticSHA256FromDigest . Hash.hashlazy--showCabalHash :: CabalHash -> Text-showCabalHash = T.append (T.pack "sha256:") . cabalHashToText---- | Information on the contents of a cabal file-data CabalFileInfo-  = CFILatest-  -- ^ Take the latest revision of the cabal file available. This-  -- isn't reproducible at all, but the running assumption (not-  -- necessarily true) is that cabal file revisions do not change-  -- semantics of the build.-  | CFIHash-      !(Maybe Int) -- file size in bytes-      !CabalHash-  -- ^ Identify by contents of the cabal file itself-  | CFIRevision !Word-  -- ^ Identify by revision number, with 0 being the original and-  -- counting upward.-    deriving (Generic, Show, Eq, Ord, Data, Typeable)-instance Store CabalFileInfo-instance NFData CabalFileInfo-instance Hashable CabalFileInfo---- | Convert from a package identifier to a tuple.-toTuple :: PackageIdentifier -> (PackageName,Version)-toTuple (PackageIdentifier n v) = (n,v)---- | Convert from a tuple to a package identifier.-fromTuple :: (PackageName,Version) -> PackageIdentifier-fromTuple (n,v) = PackageIdentifier n v---- | A parser for a package-version pair.-packageIdentifierParser :: Parser PackageIdentifier-packageIdentifierParser =-  do name <- packageNameParser-     char '-'-     PackageIdentifier name <$> versionParser---- | Convenient way to parse a package identifier from a 'Text'.-parsePackageIdentifier :: MonadThrow m => Text -> m PackageIdentifier-parsePackageIdentifier x = go x-  where go =-          either (const (throwM (PackageIdentifierParseFail x))) return .-          parseOnly (packageIdentifierParser <* endOfInput)---- | Convenience function for parsing from a 'String'.-parsePackageIdentifierFromString :: MonadThrow m => String -> m PackageIdentifier-parsePackageIdentifierFromString =-  parsePackageIdentifier . T.pack---- | Parse a 'PackageIdentifierRevision'-parsePackageIdentifierRevision :: MonadThrow m => Text -> m PackageIdentifierRevision-parsePackageIdentifierRevision x = go x-  where-    go =-      either (const (throwM (PackageIdentifierRevisionParseFail x))) return .-      parseOnly (parser <* endOfInput)--    parser = PackageIdentifierRevision-        <$> packageIdentifierParser-        <*> (cfiHash <|> cfiRevision <|> pure CFILatest)--    cfiHash = do-      _ <- string $ T.pack "@sha256:"-      hash' <- A.takeWhile (/= ',')-      hash'' <- either (\e -> fail $ "Invalid SHA256: " ++ show e) return-              $ mkCabalHashFromSHA256 hash'-      msize <- optional $ do-        _ <- A.char ','-        A.decimal-      A.endOfInput-      return $ CFIHash msize hash''--    cfiRevision = do-      _ <- string $ T.pack "@rev:"-      y <- A.decimal-      A.endOfInput-      return $ CFIRevision y--- | Get a string representation of the package identifier; name-ver.-packageIdentifierString :: PackageIdentifier -> String-packageIdentifierString (PackageIdentifier n v) = show n ++ "-" ++ show v---- | Get a string representation of the package identifier with revision; name-ver[@hashtype:hash[,size]].-packageIdentifierRevisionString :: PackageIdentifierRevision -> String-packageIdentifierRevisionString (PackageIdentifierRevision ident cfi) =-  concat $ packageIdentifierString ident : rest-  where-    rest =-      case cfi of-        CFILatest -> []-        CFIHash msize hash' ->-            "@sha256:"-          : T.unpack (cabalHashToText hash')-          : showSize msize-        CFIRevision rev -> ["@rev:", show rev]--    showSize Nothing = []-    showSize (Just int) = [',' : show int]---- | Get a Text representation of the package identifier; name-ver.-packageIdentifierText :: PackageIdentifier -> Text-packageIdentifierText = T.pack .  packageIdentifierString--toCabalPackageIdentifier :: PackageIdentifier -> C.PackageIdentifier-toCabalPackageIdentifier x =-    C.PackageIdentifier-        (toCabalPackageName (packageIdentifierName x))-        (toCabalVersion (packageIdentifierVersion x))--fromCabalPackageIdentifier :: C.PackageIdentifier -> PackageIdentifier-fromCabalPackageIdentifier (C.PackageIdentifier name version) =-    PackageIdentifier-        (fromCabalPackageName name)-        (fromCabalVersion version)
− src/Stack/Types/PackageIndex.hs 
@@ -1,183 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}--module Stack.Types.PackageIndex-    ( PackageDownload (..)-    , HSPackageDownload (..)-    , PackageCache (..)-    , OffsetSize (..)-    -- ** PackageIndex, IndexName & IndexLocation-    , PackageIndex(..)-    , IndexName(..)-    , indexNameText-    , IndexType (..)-    , HackageSecurity (..)-    ) where--import           Data.Aeson.Extended-import qualified Data.Foldable as F-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Map.Strict as Map-import qualified Data.Text as T-import           Data.Text.Encoding (encodeUtf8, decodeUtf8)-import           Path-import           Stack.Prelude-import           Stack.Types.PackageName-import           Stack.Types.PackageIdentifier-import           Stack.Types.Version-import           Data.List.NonEmpty (NonEmpty)---- | Cached information about packages in an index. We have a mapping--- from package name to a version map. Within the version map, we map--- from the version to information on an individual version. Each--- version has optional download information (about the package's--- tarball itself), and cabal file information. The cabal file--- information is a non-empty list of all cabal file revisions. Each--- file revision indicates the hash of the contents of the cabal file,--- and the offset into the index tarball.------ The reason for each 'Version' mapping to a two element list of--- 'CabalHash'es is because some older Stackage snapshots have CRs in--- their cabal files. For compatibility with these older snapshots,--- both hashes are stored: the first element of the two element list--- being the original hash, and the (potential) second element with--- the CRs stripped. [Note: This is was initially stored as a two--- element list, and cannot be easily packed into more explict ADT or--- newtype because of some template-haskell that would need to be--- modified as well: the 'versionedDecodeOrLoad' function call found--- in the 'getPackageCaches' function in 'Stack.PackageIndex'.]------ It's assumed that cabal files appear in the index tarball in the--- correct revision order.-newtype PackageCache index = PackageCache-  (HashMap PackageName-  (HashMap Version-   (index, Maybe PackageDownload, NonEmpty ([CabalHash], OffsetSize))))-  deriving (Generic, Eq, Show, Data, Typeable, Store, NFData)--instance Semigroup (PackageCache index) where-  PackageCache x <> PackageCache y = PackageCache (HashMap.unionWith HashMap.union x y)--instance Monoid (PackageCache index) where-  mempty = PackageCache HashMap.empty-  mappend = (<>)---- | offset in bytes into the 01-index.tar file for the .cabal file--- contents, and size in bytes of the .cabal file-data OffsetSize = OffsetSize !Int64 !Int64-    deriving (Generic, Eq, Show, Data, Typeable)--instance Store OffsetSize-instance NFData OffsetSize--data PackageDownload = PackageDownload-    { pdSHA256 :: !StaticSHA256-    , pdUrl    :: !ByteString-    , pdSize   :: !Word64-    }-    deriving (Show, Generic, Eq, Data, Typeable)--instance Store PackageDownload-instance NFData PackageDownload-instance FromJSON PackageDownload where-    parseJSON = withObject "PackageDownload" $ \o -> do-        hashes <- o .: "package-hashes"-        sha256' <- maybe mzero return (Map.lookup ("SHA256" :: Text) hashes)-        sha256 <--          case mkStaticSHA256FromText sha256' of-            Left e -> fail $ "Invalid sha256: " ++ show e-            Right x -> return x-        locs <- o .: "package-locations"-        url <--            case reverse locs of-                [] -> mzero-                x:_ -> return x-        size <- o .: "package-size"-        return PackageDownload-            { pdSHA256 = sha256-            , pdUrl = encodeUtf8 url-            , pdSize = size-            }---- | Hackage Security provides a different JSON format, we'll have our--- own JSON parser for it.-newtype HSPackageDownload = HSPackageDownload { unHSPackageDownload :: PackageDownload }-instance FromJSON HSPackageDownload where-    parseJSON = withObject "HSPackageDownload" $ \o1 -> do-        o2 <- o1 .: "signed"-        Object o3 <- o2 .: "targets"-        Object o4:_ <- return $ F.toList o3-        len <- o4 .: "length"-        hashes <- o4 .: "hashes"-        sha256' <- hashes .: "sha256"-        sha256 <--          case mkStaticSHA256FromText sha256' of-            Left e -> fail $ "Invalid sha256: " ++ show e-            Right x -> return x-        return $ HSPackageDownload PackageDownload-            { pdSHA256 = sha256-            , pdSize = len-            , pdUrl = ""-            }---- | Unique name for a package index-newtype IndexName = IndexName { unIndexName :: ByteString }-    deriving (Show, Eq, Ord, Hashable, Store)-indexNameText :: IndexName -> Text-indexNameText = decodeUtf8 . unIndexName-instance ToJSON IndexName where-    toJSON = toJSON . indexNameText--instance FromJSON IndexName where-    parseJSON = withText "IndexName" $ \t ->-        case parseRelDir (T.unpack t) of-            Left e -> fail $ "Invalid index name: " ++ show e-            Right _ -> return $ IndexName $ encodeUtf8 t--data IndexType = ITHackageSecurity !HackageSecurity | ITVanilla-    deriving (Show, Eq, Ord)--data HackageSecurity = HackageSecurity-    { hsKeyIds :: ![Text]-    , hsKeyThreshold :: !Int-    }-    deriving (Show, Eq, Ord)-instance FromJSON HackageSecurity where-    parseJSON = withObject "HackageSecurity" $ \o -> HackageSecurity-        <$> o .: "keyids"-        <*> o .: "key-threshold"---- | Information on a single package index-data PackageIndex = PackageIndex-    { indexName :: !IndexName-    , indexLocation :: !Text-    -- ^ URL for the tarball or, in the case of Hackage Security, the-    -- root of the directory-    , indexType :: !IndexType-    , indexDownloadPrefix :: !Text-    -- ^ URL prefix for downloading packages-    , indexRequireHashes :: !Bool-    -- ^ Require that hashes and package size information be available for packages in this index-    }-    deriving Show-instance FromJSON (WithJSONWarnings PackageIndex) where-    parseJSON = withObjectWarnings "PackageIndex" $ \o -> do-        name <- o ..: "name"-        prefix <- o ..: "download-prefix"-        http <- o ..: "http"-        mhackageSecurity <- o ..:? "hackage-security"-        let indexType' = maybe ITVanilla ITHackageSecurity mhackageSecurity-        reqHashes <- o ..:? "require-hashes" ..!= False-        return PackageIndex-            { indexName = name-            , indexLocation = http-            , indexType = indexType'-            , indexDownloadPrefix = prefix-            , indexRequireHashes = reqHashes-            }
src/Stack/Types/PackageName.hs view
@@ -1,140 +1,16 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TupleSections #-}  -- | Names for packages.  module Stack.Types.PackageName-  (PackageName-  ,PackageNameParseFail(..)-  ,packageNameParser-  ,parsePackageName-  ,parsePackageNameFromString-  ,packageNameString-  ,packageNameText-  ,fromCabalPackageName-  ,toCabalPackageName-  ,parsePackageNameFromFilePath-  ,mkPackageName-  ,packageNameArgument)-  where+    ( packageNameArgument+    ) where  import           Stack.Prelude-import           Data.Aeson.Extended-import           Data.Attoparsec.Combinators-import           Data.Attoparsec.Text-import           Data.List (intercalate)-import qualified Data.Text as T-import qualified Distribution.Package as Cabal-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax import qualified Options.Applicative as O-import           Path --- | A parse fail.-data PackageNameParseFail-  = PackageNameParseFail Text-  | CabalFileNameParseFail FilePath-  | CabalFileNameInvalidPackageName FilePath-  deriving (Typeable)-instance Exception PackageNameParseFail-instance Show PackageNameParseFail where-    show (PackageNameParseFail bs) = "Invalid package name: " ++ show bs-    show (CabalFileNameParseFail fp) = "Invalid file path for cabal file, must have a .cabal extension: " ++ fp-    show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp --- | A package name.-newtype PackageName =-  PackageName Text-  deriving (Eq,Ord,Typeable,Data,Generic,Hashable,NFData,Store,ToJSON,ToJSONKey)--instance Lift PackageName where-  lift (PackageName n) =-    appE (conE 'PackageName)-         (stringE (T.unpack n))--instance Show PackageName where-  show (PackageName n) = T.unpack n-instance Display PackageName where-  display (PackageName n) = display n--instance FromJSON PackageName where-  parseJSON j =-    do s <- parseJSON j-       case parsePackageNameFromString s of-         Nothing ->-           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 =-  fmap (PackageName . T.pack . intercalate "-")-       (sepBy1 word (char '-'))-  where-    word = concat <$> sequence [many digit,-                                pured letter,-                                many (alternating letter digit)]---- | Make a package name.-mkPackageName :: String -> Q Exp-mkPackageName s =-  case parsePackageNameFromString s of-    Nothing -> qRunIO $ throwString ("Invalid package name: " ++ show s)-    Just pn -> [|pn|]---- | Parse a package name from a 'Text'.-parsePackageName :: MonadThrow m => Text -> m PackageName-parsePackageName x = go x-  where go =-          either (const (throwM (PackageNameParseFail x))) return .-          parseOnly (packageNameParser <* endOfInput)---- | Parse a package name from a 'String'.-parsePackageNameFromString :: MonadThrow m => String -> m PackageName-parsePackageNameFromString =-  parsePackageName . T.pack---- | Produce a string representation of a package name.-packageNameString :: PackageName -> String-packageNameString (PackageName n) = T.unpack n---- | Produce a string representation of a package name.-packageNameText :: PackageName -> Text-packageNameText (PackageName n) = n---- | Convert from a Cabal package name.-fromCabalPackageName :: Cabal.PackageName -> PackageName-fromCabalPackageName name =-  let !x = T.pack $ Cabal.unPackageName name-  in PackageName x---- | Convert to a Cabal package name.-toCabalPackageName :: PackageName -> Cabal.PackageName-toCabalPackageName (PackageName name) =-  let !x = T.unpack name-  in Cabal.mkPackageName x---- | Parse a package name from a file path.-parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName-parsePackageNameFromFilePath fp = do-    base <- clean $ toFilePath $ filename fp-    case parsePackageNameFromString base of-        Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp-        Just x -> return x-  where clean = liftM reverse . strip . reverse-        strip ('l':'a':'b':'a':'c':'.':xs) = return xs-        strip _ = throwM (CabalFileNameParseFail (toFilePath fp))- -- | An argument which accepts a template name of the format -- @foo.hsfiles@. packageNameArgument :: O.Mod O.ArgumentFields PackageName@@ -145,7 +21,7 @@             either O.readerError return (p s))   where     p s =-        case parsePackageNameFromString s of+        case parsePackageName s of             Just x -> Right x             Nothing -> Left $ unlines                 [ "Expected valid package name, but got: " ++ s
src/Stack/Types/Resolver.hs view
@@ -1,11 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiWayIf #-}@@ -17,150 +13,61 @@ {-# LANGUAGE UndecidableInstances #-}  module Stack.Types.Resolver-  (Resolver-  ,IsLoaded(..)-  ,LoadedResolver-  ,ResolverWith(..)-  ,parseResolverText-  ,AbstractResolver(..)+  (AbstractResolver(..)   ,readAbstractResolver-  ,resolverRawName   ,SnapName(..)   ,Snapshots (..)   ,renderSnapName   ,parseSnapName-  ,SnapshotHash-  ,trimmedSnapshotHash-  ,snapshotHashToBS-  ,snapshotHashFromBS-  ,snapshotHashFromDigest-  ,parseCustomLocation   ) where -import           Crypto.Hash as Hash (hash, Digest, SHA256)-import           Data.Aeson.Extended-                 (ToJSON, toJSON, FromJSON, parseJSON,+import           Pantry.Internal.AesonExtended+                 (FromJSON, parseJSON,                   withObject, (.:), withText)-import qualified Data.ByteString as B-import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.HashMap.Strict as HashMap import qualified Data.IntMap.Strict as IntMap import qualified Data.Text as T-import           Data.Text.Encoding (decodeUtf8) import           Data.Text.Read (decimal) import           Data.Time (Day)-import           Network.HTTP.StackClient (Request, parseUrlThrow) import           Options.Applicative (ReadM) import qualified Options.Applicative.Types as OA-import           Path import           Stack.Prelude-import           Stack.Types.Compiler-import           Stack.Types.PackageIdentifier-import qualified System.FilePath as FP -data IsLoaded = Loaded | NotLoaded--type LoadedResolver = ResolverWith SnapshotHash-type Resolver = ResolverWith (Either Request FilePath)---- 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 ResolverWith customContents-    = ResolverStackage !SnapName-    -- ^ Use an official snapshot from the Stackage project, either an-    -- LTS Haskell or Stackage Nightly.--    | ResolverCompiler !(CompilerVersion 'CVWanted)-    -- ^ 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.--    | ResolverCustom !Text !customContents-    -- ^ A custom resolver based on the given location (as a raw URL-    -- or filepath). If @customContents@ is a @Either Request-    -- FilePath@, it represents the parsed location value (with-    -- filepaths resolved relative to the directory containing the-    -- file referring to the custom snapshot). Once it has been loaded-    -- from disk, it will be replaced with a @SnapshotHash@ value,-    -- which is used to store cached files.-    deriving (Generic, Typeable, Show, Data, Eq, Functor, Foldable, Traversable)-instance Store LoadedResolver-instance NFData LoadedResolver--instance ToJSON (ResolverWith a) where-    toJSON x = case x of-        ResolverStackage name -> toJSON $ renderSnapName name-        ResolverCompiler version -> toJSON $ compilerVersionText version-        ResolverCustom loc _ -> toJSON loc-instance a ~ () => FromJSON (ResolverWith a) where-    parseJSON = withText "ResolverWith ()" $ return . parseResolverText---- | Convert a Resolver into its @Text@ representation for human--- presentation. When possible, you should prefer @sdResolverName@, as--- it will handle the human-friendly name inside a custom snapshot.-resolverRawName :: ResolverWith a -> Text-resolverRawName (ResolverStackage name) = renderSnapName name-resolverRawName (ResolverCompiler v) = compilerVersionText v-resolverRawName (ResolverCustom loc _ ) = "custom: " <> loc--parseCustomLocation-  :: MonadThrow m-  => Maybe (Path Abs Dir) -- ^ directory config value was read from-  -> ResolverWith () -- could technically be any type parameter, restricting to help with type safety-  -> m Resolver-parseCustomLocation mdir (ResolverCustom t ()) =-  ResolverCustom t <$> case parseUrlThrow $ T.unpack t of-    Nothing -> Right <$> do-      dir <--        case mdir of-          Nothing -> throwM $ FilepathInDownloadedSnapshot t-          Just x -> return x-      let rel =-              T.unpack-            $ fromMaybe t-            $ T.stripPrefix "file://" t <|> T.stripPrefix "file:" t-      return $ toFilePath dir FP.</> rel-    Just req -> return $ Left req-parseCustomLocation _ (ResolverStackage name) = return $ ResolverStackage name-parseCustomLocation _ (ResolverCompiler cv) = return $ ResolverCompiler cv---- | Parse a @Resolver@ from a @Text@-parseResolverText :: Text -> ResolverWith ()-parseResolverText t-    | Right x <- parseSnapName t = ResolverStackage x-    | Just v <- parseCompilerVersion t = ResolverCompiler v-    | otherwise = ResolverCustom t ()- -- | Either an actual resolver value, or an abstract description of one (e.g., -- latest nightly). data AbstractResolver     = ARLatestNightly     | ARLatestLTS     | ARLatestLTSMajor !Int-    | ARResolver !(ResolverWith ())+    | ARResolver !RawSnapshotLocation     | ARGlobal-    deriving Show -readAbstractResolver :: ReadM AbstractResolver+instance Show AbstractResolver where+  show = T.unpack . utf8BuilderToText . display++instance Display AbstractResolver where+  display ARLatestNightly = "nightly"+  display ARLatestLTS = "lts"+  display (ARLatestLTSMajor x) = "lts-" <> display x+  display (ARResolver usl) = display usl+  display ARGlobal = "global"++readAbstractResolver :: ReadM (Unresolved AbstractResolver) readAbstractResolver = do     s <- OA.readerAsk     case s of-        "global" -> return ARGlobal-        "nightly" -> return ARLatestNightly-        "lts" -> return ARLatestLTS+        "global" -> pure $ pure ARGlobal+        "nightly" -> pure $ pure ARLatestNightly+        "lts" -> pure $ pure ARLatestLTS         'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x ->-            return $ ARLatestLTSMajor x'-        _ -> return $ ARResolver $ parseResolverText $ T.pack s+            pure $ pure $ ARLatestLTSMajor x'+        _ -> pure $ ARResolver <$> parseRawSnapshotLocation (T.pack s)  -- | The name of an LTS Haskell or Stackage Nightly snapshot. data SnapName     = LTS !Int !Int     | Nightly !Day     deriving (Generic, Typeable, Show, Data, Eq)-instance Store SnapName instance NFData SnapName instance Display SnapName where   display = display . renderSnapName@@ -234,25 +141,3 @@                 Left e -> fail $ show e                 Right (LTS x y) -> return $ IntMap.singleton x y                 Right (Nightly _) -> fail "Unexpected nightly value"--newtype SnapshotHash = SnapshotHash { unSnapshotHash :: StaticSHA256 }-    deriving (Generic, Typeable, Show, Data, Eq)-instance Store SnapshotHash-instance NFData SnapshotHash---- | Return the first 12 characters of the hash as a B64URL-encoded--- string.-trimmedSnapshotHash :: SnapshotHash -> Text-trimmedSnapshotHash = decodeUtf8 . B.take 12 . B64URL.encode . staticSHA256ToRaw . unSnapshotHash---- | Return the raw bytes in the hash-snapshotHashToBS :: SnapshotHash -> ByteString-snapshotHashToBS = staticSHA256ToRaw . unSnapshotHash---- | Create a new SnapshotHash by SHA256 hashing the given contents-snapshotHashFromBS :: ByteString -> SnapshotHash-snapshotHashFromBS = snapshotHashFromDigest . Hash.hash---- | Create a new SnapshotHash from the given digest-snapshotHashFromDigest :: Digest SHA256 -> SnapshotHash-snapshotHashFromDigest = SnapshotHash . mkStaticSHA256FromDigest
− src/Stack/Types/Runner.hs 
@@ -1,119 +0,0 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}---- | Run environment--module Stack.Types.Runner-    ( Runner (..)-    , HasRunner (..)-    , terminalL-    , useColorL-    , reExecL-    , ColorWhen (..)-    , withRunner-    ) where--import           Distribution.PackageDescription (GenericPackageDescription)-import           Lens.Micro-import           Stack.Prelude              hiding (lift)-import           Stack.Constants-import           Stack.Types.PackageIdentifier (PackageIdentifierRevision)-import           System.Console.ANSI-import           RIO.Process (HasProcessContext (..), ProcessContext, mkDefaultProcessContext)-import           System.Terminal---- | Monadic environment.-data Runner = Runner-  { runnerReExec     :: !Bool-  , runnerTerminal   :: !Bool-  , runnerUseColor   :: !Bool-  , runnerLogFunc    :: !LogFunc-  , runnerTermWidth  :: !Int-  , runnerProcessContext :: !ProcessContext-  , runnerParsedCabalFiles :: !(IORef-      ( Map PackageIdentifierRevision GenericPackageDescription-      , Map (Path Abs Dir)            (GenericPackageDescription, Path Abs File)-      ))-  -- ^ Cache of previously parsed cabal files.-  ---  -- TODO: This is really an ugly hack to avoid spamming the user with-  -- warnings when we parse cabal files multiple times and bypass-  -- performance issues. Ideally: we would just design the system such-  -- that it only ever parses a cabal file once. But for now, this is-  -- a decent workaround. See:-  -- <https://github.com/commercialhaskell/stack/issues/3591>.-  }--class (HasProcessContext env, HasLogFunc env) => HasRunner env where-  runnerL :: Lens' env Runner-instance HasProcessContext Runner where-  processContextL = lens runnerProcessContext (\x y -> x { runnerProcessContext = y })-instance HasRunner Runner where-  runnerL = id--terminalL :: HasRunner env => Lens' env Bool-terminalL = runnerL.lens runnerTerminal (\x y -> x { runnerTerminal = y })--useColorL :: HasRunner env => Lens' env Bool-useColorL = runnerL.lens runnerUseColor (\x y -> x { runnerUseColor = y })--reExecL :: HasRunner env => Lens' env Bool-reExecL = runnerL.lens runnerReExec (\x y -> x { runnerReExec = y })------------------------------------------------------------------------------------- Logging functionality--instance HasLogFunc Runner where-  logFuncL = lens runnerLogFunc (\x y -> x { runnerLogFunc = y })---- | With a 'Runner', do the thing-withRunner :: MonadUnliftIO m-           => LogLevel-           -> Bool -- ^ use time?-           -> Bool -- ^ terminal?-           -> ColorWhen-           -> Maybe Int -- ^ terminal width override-           -> Bool -- ^ reexec?-           -> (Runner -> m a)-           -> m a-withRunner logLevel useTime terminal colorWhen widthOverride reExec inner = do-  useColor <- case colorWhen of-    ColorNever -> return False-    ColorAlways -> return True-    ColorAuto -> liftIO $ hSupportsANSI stderr-  termWidth <- clipWidth <$> maybe (fromMaybe defaultTerminalWidth-                                    <$> liftIO getTerminalWidth)-                                   pure widthOverride-  ref <- newIORef mempty-  menv <- mkDefaultProcessContext-  logOptions0 <- logOptionsHandle stderr False-  let logOptions-        = setLogUseColor useColor-        $ setLogUseTime useTime-        $ setLogMinLevel logLevel-        $ setLogVerboseFormat (logLevel <= LevelDebug)-        $ setLogTerminal terminal-          logOptions0-  withLogFunc logOptions $ \logFunc -> inner Runner-    { runnerReExec = reExec-    , runnerTerminal = terminal-    , runnerUseColor = useColor-    , runnerLogFunc = logFunc-    , runnerTermWidth = termWidth-    , runnerParsedCabalFiles = ref-    , runnerProcessContext = menv-    }-  where clipWidth w-          | w < minTerminalWidth = minTerminalWidth-          | w > maxTerminalWidth = maxTerminalWidth-          | otherwise = w--data ColorWhen = ColorNever | ColorAlways | ColorAuto-    deriving (Eq, Show, Generic)
− src/Stack/Types/Sig.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances  #-}-{-# LANGUAGE OverloadedStrings  #-}--{-|-Module      : Stack.Types.Sig-Description : Signature Types-Copyright   : (c) 2015-2018, Stack contributors-License     : BSD3-Maintainer  : Tim Dysinger <tim@fpcomplete.com>-Stability   : experimental-Portability : POSIX--}--module Stack.Types.Sig-       (Signature(..), Fingerprint, mkFingerprint, SigException(..)) where--import           Stack.Prelude-import           Data.Aeson (Value(..), ToJSON(..), FromJSON(..))-import qualified Data.ByteString as SB-import           Data.Char (isHexDigit)-import qualified Data.Text as T-import           Stack.Types.PackageName---- | A GPG signature.-newtype Signature =-    Signature ByteString-    deriving (Ord,Eq)--instance Show Signature where-    show (Signature s) = "Signature " ++-        (if SB.length s > 140-             then show (SB.take 140 s) ++-                  "..."-             else show (SB.take 140 s))---- | The GPG fingerprint.-newtype Fingerprint =-    Fingerprint Text-    deriving (Eq,Ord)--mkFingerprint :: Text -> Fingerprint-mkFingerprint = Fingerprint . hexText--hexText :: Text -> Text-hexText = T.toUpper . T.dropWhile (not . isHexDigit)--instance Show Fingerprint where-    show (Fingerprint hex) = T.unpack (hexText hex)--instance FromJSON Fingerprint where-    parseJSON j = Fingerprint . hexText <$> parseJSON j--instance ToJSON Fingerprint where-    toJSON (Fingerprint hex) = String (hexText hex)--instance IsString Fingerprint where-    fromString = Fingerprint . hexText . T.pack--instance FromJSON (Aeson PackageName) where-    parseJSON j = do-        s <- parseJSON j-        case parsePackageName s of-            Just name -> return (Aeson name)-            Nothing -> fail ("Invalid package name: " <> T.unpack s)---- | Handy wrapper for orphan instances.-newtype Aeson a = Aeson-    { _unAeson :: a-    } deriving (Ord,Eq)---- | Exceptions-data SigException-    = GPGFingerprintException String-    | GPGNotFoundException-    | GPGSignException String-    | GPGVerifyException String-    | SigInvalidSDistTarBall-    | SigNoProjectRootException-    | SigServiceException String-    deriving (Typeable)--instance Exception SigException--instance Show SigException where-    show (GPGFingerprintException e) =-        "Error extracting a GPG fingerprint " <> e-    show GPGNotFoundException = "Unable to find gpg2 or gpg executable"-    show (GPGSignException e) = "Error signing with GPG " <> e-    show (GPGVerifyException e) = "Error verifying with GPG " <> e-    show SigNoProjectRootException = "Missing Project Root"-    show SigInvalidSDistTarBall = "Invalid sdist tarball"-    show (SigServiceException e) = "Error with the Signature Service " <> e
+ src/Stack/Types/SourceMap.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- | A sourcemap maps a package name to how it should be built,+-- including source code, flags, options, etc. This module contains+-- various stages of source map construction. See the+-- @build_overview.md@ doc for details on these stages.+module Stack.Types.SourceMap+  ( -- * Different source map types+    SMWanted (..)+  , SMActual (..)+  , Target (..)+  , PackageType (..)+  , SMTargets (..)+  , SourceMap (..)+    -- * Helper types+  , FromSnapshot (..)+  , DepPackage (..)+  , ProjectPackage (..)+  , CommonPackage (..)+  , GlobalPackageVersion (..)+  , GlobalPackage (..)+  , isReplacedGlobal+  , SourceMapHash (..)+  , smRelDir+  ) where++import qualified Data.Text as T+import qualified Pantry.SHA256 as SHA256+import Path+import Stack.Prelude+import Stack.Types.Compiler+import Stack.Types.NamedComponent+import Distribution.PackageDescription (GenericPackageDescription)++-- | Common settings for both dependency and project package.+data CommonPackage = CommonPackage+  { cpGPD :: !(IO GenericPackageDescription)+  , cpName :: !PackageName+  , cpFlags :: !(Map FlagName Bool)+  -- ^ overrides default flags+  , cpGhcOptions :: ![Text] -- also lets us know if we're doing profiling+  , cpCabalConfigOpts :: ![Text]+  , cpHaddocks :: !Bool+  }++-- | Flag showing if package comes from a snapshot+-- needed to ignore dependency bounds between such packages+data FromSnapshot+    = FromSnapshot+    | NotFromSnapshot+    deriving (Show)++-- | A view of a dependency package, specified in stack.yaml+data DepPackage = DepPackage+  { dpCommon :: !CommonPackage+  , dpLocation :: !PackageLocation+  , dpHidden :: !Bool+  -- ^ Should the package be hidden after registering?+  -- Affects the script interpreter's module name import parser.+  , dpFromSnapshot :: !FromSnapshot+  -- ^ Needed to ignore bounds between snapshot packages+  -- See https://github.com/commercialhaskell/stackage/issues/3185+  }++-- | A view of a project package needed for resolving components+data ProjectPackage = ProjectPackage+  { ppCommon :: !CommonPackage+  , ppCabalFP    :: !(Path Abs File)+  , ppResolvedDir :: !(ResolvedPath Dir)+  }++-- | A view of a package installed in the global package database also+-- could include marker for a replaced global package (could be replaced+-- because of a replaced dependency)+data GlobalPackage+  = GlobalPackage !Version+  | ReplacedGlobalPackage ![PackageName]+  deriving Eq++isReplacedGlobal :: GlobalPackage -> Bool+isReplacedGlobal (ReplacedGlobalPackage _) = True+isReplacedGlobal (GlobalPackage _) = False++-- | A source map with information on the wanted (but not actual)+-- compiler. This is derived by parsing the @stack.yaml@ file for+-- @packages@, @extra-deps@, their configuration (e.g., flags and+-- options), and parsing the snapshot it refers to. It does not+-- include global packages or any information from the command line.+--+-- Invariant: a @PackageName@ appears in either 'smwProject' or+-- 'smwDeps', but not both.+data SMWanted = SMWanted+  { smwCompiler :: !WantedCompiler+  , smwProject :: !(Map PackageName ProjectPackage)+  , smwDeps :: !(Map PackageName DepPackage)+  , smwSnapshotLocation :: !RawSnapshotLocation+  -- ^ Where this snapshot is loaded from.+  }++-- | Adds in actual compiler information to 'SMWanted', in particular+-- the contents of the global package database.+--+-- Invariant: a @PackageName@ appears in only one of the @Map@s.+data SMActual global = SMActual+  { smaCompiler :: !ActualCompiler+  , smaProject :: !(Map PackageName ProjectPackage)+  , smaDeps :: !(Map PackageName DepPackage)+  , smaGlobal :: !(Map PackageName global)+  }++newtype GlobalPackageVersion = GlobalPackageVersion Version++-- | How a package is intended to be built+data Target+  = TargetAll !PackageType+  -- ^ Build all of the default components.+  | TargetComps !(Set NamedComponent)+  -- ^ Only build specific components++data PackageType = PTProject | PTDependency+  deriving (Eq, Show)++-- | Builds on an 'SMActual' by resolving the targets specified on the+-- command line, potentially adding in new dependency packages in the+-- process.+data SMTargets = SMTargets+  { smtTargets :: !(Map PackageName Target)+  , smtDeps :: !(Map PackageName DepPackage)+  }++-- | The final source map, taking an 'SMTargets' and applying all+-- command line flags and GHC options.+data SourceMap = SourceMap+  { smTargets :: !SMTargets+    -- ^ Doesn't need to be included in the hash, does not affect the+    -- source map.+  , smCompiler :: !ActualCompiler+    -- ^ Need to hash the compiler version _and_ its installation+    -- path.  Ideally there would be some kind of output from GHC+    -- telling us some unique ID for the compiler itself.+  , smProject :: !(Map PackageName ProjectPackage)+    -- ^ Doesn't need to be included in hash, doesn't affect any of+    -- the packages that get stored in the snapshot database.+  , smDeps :: !(Map PackageName DepPackage)+    -- ^ Need to hash all of the immutable dependencies, can ignore+    -- the mutable dependencies.+  , smGlobal :: !(Map PackageName GlobalPackage)+    -- ^ Doesn't actually need to be hashed, implicitly captured by+    -- smCompiler. Can be broken if someone installs new global+    -- packages. We can document that as not supported, _or_ we could+    -- actually include all of this in the hash and make Stack more+    -- resilient.+  }++-- | A unique hash for the immutable portions of a 'SourceMap'.+newtype SourceMapHash = SourceMapHash SHA256++-- | Returns relative directory name with source map's hash+smRelDir :: (MonadThrow m) => SourceMapHash -> m (Path Rel Dir)+smRelDir (SourceMapHash smh) = parseRelDir $ T.unpack $ SHA256.toHexText smh
src/Stack/Types/TemplateName.hs view
@@ -1,8 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | Template name handling. @@ -11,22 +8,20 @@   , RepoTemplatePath (..)   , RepoService (..)   , TemplatePath (..)-  , mkTemplateName   , templateName   , templatePath   , parseTemplateNameFromString   , parseRepoPathWithService   , templateNameArgument   , templateParamArgument+  , defaultTemplateName   ) where  import           Data.Aeson (FromJSON (..), withText) import qualified Data.Text as T-import           Language.Haskell.TH import           Network.HTTP.StackClient (parseRequest) import qualified Options.Applicative as O import           Path-import           Path.Internal import           Stack.Prelude  -- | A template name.@@ -35,9 +30,11 @@  data TemplatePath = AbsPath (Path Abs File)                   -- ^ an absolute path on the filesystem-                  | RelPath (Path Rel File)+                  | RelPath String (Path Rel File)                   -- ^ a relative path on the filesystem, or relative to-                  -- the template repository+                  -- the template repository. To avoid path separator conversion+                  -- on Windows, the raw command-line parameter passed is also+                  -- given as the first field (possibly with @.hsfiles@ appended).                   | UrlPath String                   -- ^ a full URL                   | RepoPath RepoTemplatePath@@ -96,28 +93,17 @@         [ TemplateName prefix        . RepoPath <$> parseRepoPath hsf         , TemplateName (T.pack orig) . UrlPath <$> (parseRequest orig *> Just orig)         , TemplateName prefix        . AbsPath <$> parseAbsFile hsf-        , TemplateName prefix        . RelPath <$> parseRelFile hsf+        , TemplateName prefix        . RelPath hsf <$> parseRelFile hsf         ]     expected = "Expected a template like: foo or foo.hsfiles or\                \ https://example.com/foo.hsfiles or github:user/foo" --- | Make a template name.-mkTemplateName :: String -> Q Exp-mkTemplateName s =-    case parseTemplateNameFromString s of-        Left{} -> runIO $ throwString ("Invalid template name: " ++ show s)-        Right (TemplateName (T.unpack -> prefix) p) ->-            [|TemplateName (T.pack prefix) $(pn)|]-            where pn =-                      case p of-                          AbsPath (Path fp) -> [|AbsPath (Path fp)|]-                          RelPath (Path fp) -> [|RelPath (Path fp)|]-                          UrlPath fp -> [|UrlPath fp|]-                          RepoPath (RepoTemplatePath sv u t) ->-                            case sv of-                                Github    -> [|RepoPath $ RepoTemplatePath Github u t|]-                                Gitlab    -> [|RepoPath $ RepoTemplatePath Gitlab u t|]-                                Bitbucket -> [|RepoPath $ RepoTemplatePath Bitbucket u t|]+-- | The default template name you can use if you don't have one.+defaultTemplateName :: TemplateName+defaultTemplateName =+  case parseTemplateNameFromString "new-template" of+    Left s -> error $ "Bug in Stack codebase, cannot parse default template name: " ++ s+    Right x -> x  -- | Get a text representation of the template name. templateName :: TemplateName -> Text@@ -149,4 +135,3 @@         repoUser <- defaultRepoUserForService service         Just $ RepoTemplatePath service repoUser name     _            -> Nothing-
− src/Stack/Types/Urls.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}--module Stack.Types.Urls where--import Data.Aeson.Extended-import Generics.Deriving.Monoid (memptydefault, mappenddefault)-import Stack.Prelude--data Urls = Urls-    { urlsLatestSnapshot :: !Text-    , urlsLtsBuildPlans :: !Text-    , urlsNightlyBuildPlans :: !Text-    }-    deriving Show---- TODO: Really need this instance?-instance FromJSON (WithJSONWarnings Urls) where-    parseJSON = withObjectWarnings "Urls" $ \o -> do-        Urls-            <$> o ..: "latest-snapshot"-            <*> o ..: "lts-build-plans"-            <*> o ..: "nightly-build-plans"--data UrlsMonoid = UrlsMonoid-    { urlsMonoidLatestSnapshot :: !(First Text)-    , urlsMonoidLtsBuildPlans :: !(First Text)-    , urlsMonoidNightlyBuildPlans :: !(First Text)-    }-    deriving (Show, Generic)--instance FromJSON (WithJSONWarnings UrlsMonoid) where-    parseJSON = withObjectWarnings "UrlsMonoid" $ \o -> do-        UrlsMonoid-            <$> o ..: "latest-snapshot"-            <*> o ..: "lts-build-plans"-            <*> o ..: "nightly-build-plans"--instance Semigroup UrlsMonoid where-    (<>) = mappenddefault--instance Monoid UrlsMonoid where-    mempty = memptydefault-    mappend = (<>)
src/Stack/Types/Version.hs view
@@ -1,11 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns #-}  -- | Versions for packages. @@ -14,14 +10,6 @@   ,Cabal.VersionRange -- TODO in the future should have a newtype wrapper   ,IntersectingVersionRange(..)   ,VersionCheck(..)-  ,versionParser-  ,parseVersion-  ,parseVersionFromString-  ,versionString-  ,versionText-  ,toCabalVersion-  ,fromCabalVersion-  ,mkVersion   ,versionRangeText   ,withinRange   ,Stack.Types.Version.intersectVersionRanges@@ -29,74 +17,21 @@   ,latestApplicableVersion   ,checkVersion   ,nextMajorVersion-  ,UpgradeTo(..)   ,minorVersion   ,stackVersion   ,stackMinorVersion)   where  import           Stack.Prelude hiding (Vector)-import           Data.Aeson.Extended-import           Data.Attoparsec.Text-import           Data.Hashable (Hashable (..))-import           Data.List+import           Pantry.Internal.AesonExtended import qualified Data.Set as Set import qualified Data.Text as T-import           Data.Vector.Unboxed (Vector)-import qualified Data.Vector.Unboxed as V import           Distribution.Text (disp) import qualified Distribution.Version as Cabal-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax+import           Distribution.Version (Version, versionNumbers, withinRange) import qualified Paths_stack as Meta import           Text.PrettyPrint (render) --- | A parse fail.-newtype VersionParseFail =-  VersionParseFail Text-  deriving (Typeable)-instance Exception VersionParseFail-instance Show VersionParseFail where-    show (VersionParseFail bs) = "Invalid version: " ++ show bs---- | A Package upgrade; Latest or a specific version.-data UpgradeTo = Specific Version | Latest deriving (Show)---- | A package version.-newtype Version =-  Version {unVersion :: Vector Word}-  deriving (Eq,Ord,Typeable,Data,Generic,Store,NFData)--instance Hashable Version where-  hashWithSalt i = hashWithSalt i . V.toList . unVersion--instance Lift Version where-  lift (Version n) =-    appE (conE 'Version)-         (appE (varE 'V.fromList)-               (listE (map (litE . IntegerL . fromIntegral)-                           (V.toList n))))--instance Show Version where-  show (Version v) =-    intercalate "."-                (map show (V.toList v))-instance Display Version where-  display = display . versionText--instance ToJSON Version where-  toJSON = toJSON . versionText-instance FromJSON Version where-  parseJSON j =-    do s <- parseJSON j-       case parseVersionFromString s of-         Nothing ->-           fail ("Couldn't parse package version: " ++ s)-         Just ver -> return ver-instance FromJSONKey Version where-  fromJSONKey = FromJSONKeyTextParser $ \k ->-    either (fail . show) return $ parseVersion k- newtype IntersectingVersionRange =     IntersectingVersionRange { getIntersectingVersionRange :: Cabal.VersionRange }     deriving Show@@ -109,79 +44,21 @@     mempty = IntersectingVersionRange Cabal.anyVersion     mappend = (<>) --- | Attoparsec parser for a package version.-versionParser :: Parser Version-versionParser =-  do ls <- (:) <$> num <*> many num'-     let !v = V.fromList ls-     return (Version v)-  where num = decimal-        num' = point *> num-        point = satisfy (== '.')---- | Convenient way to parse a package version from a 'Text'.-parseVersion :: MonadThrow m => Text -> m Version-parseVersion x = go x-  where go =-          either (const (throwM (VersionParseFail x))) return .-          parseOnly (versionParser <* endOfInput)---- | Migration function.-parseVersionFromString :: MonadThrow m => String -> m Version-parseVersionFromString =-  parseVersion . T.pack---- | Get a string representation of a package version.-versionString :: Version -> String-versionString (Version v) =-  intercalate "."-              (map show (V.toList v))---- | Get a string representation of a package version.-versionText :: Version -> Text-versionText (Version v) =-  T.intercalate-    "."-    (map (T.pack . show)-         (V.toList v))---- | Convert to a Cabal version.-toCabalVersion :: Version -> Cabal.Version-toCabalVersion (Version v) =-  Cabal.mkVersion (map fromIntegral (V.toList v))---- | Convert from a Cabal version.-fromCabalVersion :: Cabal.Version -> Version-fromCabalVersion vs =-  let !v = V.fromList (map fromIntegral (Cabal.versionNumbers vs))-  in Version v---- | Make a package version.-mkVersion :: String -> Q Exp-mkVersion s =-  case parseVersionFromString s of-    Nothing -> qRunIO $ throwString ("Invalid package version: " ++ show s)-    Just pn -> [|pn|]- -- | Display a version range versionRangeText :: Cabal.VersionRange -> Text versionRangeText = T.pack . render . disp --- | Check if a version is within a version range.-withinRange :: Version -> Cabal.VersionRange -> Bool-withinRange v r = toCabalVersion v `Cabal.withinRange` r- -- | A modified intersection which also simplifies, for better display. intersectVersionRanges :: Cabal.VersionRange -> Cabal.VersionRange -> Cabal.VersionRange intersectVersionRanges x y = Cabal.simplifyVersionRange $ Cabal.intersectVersionRanges x y  -- | Returns the first two components, defaulting to 0 if not present toMajorVersion :: Version -> Version-toMajorVersion  (Version v) =-    case V.length v of-        0 -> Version (V.fromList [0,        0])-        1 -> Version (V.fromList [V.head v, 0])-        _ -> Version (V.fromList [V.head v, v V.! 1])+toMajorVersion v =+  case versionNumbers v of+    []    -> Cabal.mkVersion [0, 0]+    [a]   -> Cabal.mkVersion [a, 0]+    a:b:_ -> Cabal.mkVersion [a, b]  -- | Given a version range and a set of versions, find the latest version from -- the set that is within the range.@@ -190,11 +67,11 @@  -- | Get the next major version number for the given version nextMajorVersion :: Version -> Version-nextMajorVersion (Version v) =-  case  V.length v of-    0 -> Version (V.fromList [0,        1])-    1 -> Version (V.fromList [V.head v, 1])-    _ -> Version (V.fromList [V.head v, (v V.! 1) + 1])+nextMajorVersion v =+  case versionNumbers v of+    []    -> Cabal.mkVersion [0, 1]+    [a]   -> Cabal.mkVersion [a, 1]+    a:b:_ -> Cabal.mkVersion [a, b + 1]  data VersionCheck     = MatchMinor@@ -216,26 +93,30 @@         expected = "VersionCheck value (match-minor, match-exact, or newer-minor)"  checkVersion :: VersionCheck -> Version -> Version -> Bool-checkVersion check (Version wanted) (Version actual) =+checkVersion check (versionNumbers -> wanted) (versionNumbers -> actual) =     case check of-        MatchMinor -> V.and (V.take 3 matching)-        MatchExact -> V.length wanted == V.length actual && V.and matching-        NewerMinor -> V.and (V.take 2 matching) && newerMinor+        MatchMinor -> and (take 3 matching)+        MatchExact -> length wanted == length actual && and matching+        NewerMinor -> and (take 2 matching) && newerMinor   where-    matching = V.zipWith (==) wanted actual+    matching = zipWith (==) wanted actual++    getMinor (_a:_b:c:_) = Just c+    getMinor _ = Nothing+     newerMinor =-        case (wanted V.!? 2, actual V.!? 2) of+        case (getMinor wanted, getMinor actual) of             (Nothing, _) -> True             (Just _, Nothing) -> False             (Just w, Just a) -> a >= w  -- | Get minor version (excludes any patchlevel) minorVersion :: Version -> Version-minorVersion (Version v) = Version (V.take 3 v)+minorVersion = Cabal.mkVersion . take 3 . versionNumbers  -- | Current Stack version stackVersion :: Version-stackVersion = fromCabalVersion (Cabal.mkVersion' Meta.version)+stackVersion = Cabal.mkVersion' Meta.version  -- | Current Stack minor version (excludes patchlevel) stackMinorVersion :: Version
src/Stack/Types/VersionIntervals.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-}-module Stack.Types.VersionIntervals+module Stack.Types.VersionIntervals -- to be removed with https://github.com/commercialhaskell/stack/issues/4213   ( VersionIntervals   , toVersionRange   , fromVersionRange@@ -16,7 +16,6 @@  newtype VersionIntervals = VersionIntervals [VersionInterval]     deriving (Generic, Show, Eq, Data, Typeable)-instance Store VersionIntervals instance NFData VersionIntervals  data VersionInterval = VersionInterval@@ -25,12 +24,10 @@   , viUpper :: !(Maybe (Version, Bound))   }     deriving (Generic, Show, Eq, Data, Typeable)-instance Store VersionInterval instance NFData VersionInterval  data Bound = ExclusiveBound | InclusiveBound     deriving (Generic, Show, Eq, Data, Typeable)-instance Store Bound instance NFData Bound  toVersionRange :: VersionIntervals -> C.VersionRange@@ -40,7 +37,7 @@ fromVersionRange = fromCabal . C.toVersionIntervals  withinIntervals :: Version -> VersionIntervals -> Bool-withinIntervals v vi = C.withinIntervals (toCabalVersion v) (toCabal vi)+withinIntervals v vi = C.withinIntervals v (toCabal vi)  unionVersionIntervals :: VersionIntervals -> VersionIntervals -> VersionIntervals unionVersionIntervals x y = fromCabal $ C.unionVersionIntervals@@ -57,10 +54,10 @@   C.mkVersionIntervals $ map go vi   where     go (VersionInterval lowerV lowerB mupper) =-        ( C.LowerBound (toCabalVersion lowerV) (toCabalBound lowerB)+        ( C.LowerBound lowerV (toCabalBound lowerB)         , case mupper of             Nothing -> C.NoUpperBound-            Just (v, b) -> C.UpperBound (toCabalVersion v) (toCabalBound b)+            Just (v, b) -> C.UpperBound v (toCabalBound b)         )  fromCabal :: C.VersionIntervals -> VersionIntervals@@ -68,12 +65,12 @@     VersionIntervals . map go . C.versionIntervals   where     go (C.LowerBound lowerV lowerB, upper) = VersionInterval-      { viLowerVersion = fromCabalVersion lowerV+      { viLowerVersion = lowerV       , viLowerBound = fromCabalBound lowerB       , viUpper =           case upper of             C.NoUpperBound -> Nothing-            C.UpperBound v b -> Just (fromCabalVersion v, fromCabalBound b)+            C.UpperBound v b -> Just (v, fromCabalBound b)       }  toCabalBound :: Bound -> C.Bound
+ src/Stack/Unpack.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Stack.Unpack+  ( unpackPackages+  ) where++import Stack.Prelude+import qualified RIO.Text as T+import qualified RIO.Map as Map+import qualified RIO.Set as Set+import RIO.List (intercalate)+import RIO.Process (HasProcessContext)+import Path ((</>), parseRelDir)+import Path.IO (doesDirExist)++data UnpackException+  = UnpackDirectoryAlreadyExists (Set (Path Abs Dir))+  | CouldNotParsePackageSelectors [String]+    deriving Typeable+instance Exception UnpackException+instance Show UnpackException where+    show (UnpackDirectoryAlreadyExists dirs) = unlines+        $ "Unable to unpack due to already present directories:"+        : map (("    " ++) . toFilePath) (Set.toList dirs)+    show (CouldNotParsePackageSelectors strs) = unlines+      $ "The following package selectors are not valid package names or identifiers:"+      : map ("- " ++) strs++-- | Intended to work for the command line command.+unpackPackages+  :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)+  => Maybe RawSnapshot -- ^ when looking up by name, take from this build plan+  -> Path Abs Dir -- ^ destination+  -> [String] -- ^ names or identifiers+  -> RIO env ()+unpackPackages mSnapshot dest input = do+    let (errs1, (names, pirs1)) =+          fmap partitionEithers $ partitionEithers $ map parse input+    locs1 <- forM pirs1 $ \pir -> do+      loc <- completePackageLocation $ RPLIHackage pir Nothing+      pure (loc, packageLocationIdent loc)+    (errs2, locs2) <- partitionEithers <$> traverse toLoc names+    case errs1 ++ errs2 of+      [] -> pure ()+      errs -> throwM $ CouldNotParsePackageSelectors errs+    locs <- Map.fromList <$> mapM+          (\(pir, ident) -> do+              suffix <- parseRelDir $ packageIdentifierString ident+              pure (pir, dest </> suffix)+          )+          (locs1 ++ locs2)++    alreadyUnpacked <- filterM doesDirExist $ Map.elems locs++    unless (null alreadyUnpacked) $+        throwM $ UnpackDirectoryAlreadyExists $ Set.fromList alreadyUnpacked++    forM_ (Map.toList locs) $ \(loc, dest') -> do+      unpackPackageLocation dest' loc+      logInfo $+        "Unpacked " <>+        display loc <>+        " to " <>+        fromString (toFilePath dest')+  where+    toLoc | Just snapshot <- mSnapshot = toLocSnapshot snapshot+          | otherwise = toLocNoSnapshot++    toLocNoSnapshot :: PackageName -> RIO env (Either String (PackageLocationImmutable, PackageIdentifier))+    toLocNoSnapshot name = do+      mloc1 <- getLatestHackageLocation YesRequireHackageIndex name UsePreferredVersions+      mloc <-+        case mloc1 of+          Just _ -> pure mloc1+          Nothing -> do+            updated <- updateHackageIndex $ Just $ "Could not find package " <> fromString (packageNameString name) <> ", updating"+            case updated of+              UpdateOccurred -> getLatestHackageLocation YesRequireHackageIndex name UsePreferredVersions+              NoUpdateOccurred -> pure Nothing+      case mloc of+        Nothing -> do+          candidates <- getHackageTypoCorrections name+          pure $ Left $ concat+            [ "Could not find package "+            , packageNameString name+            , " on Hackage"+            , if null candidates+                then ""+                else ". Perhaps you meant: " ++ intercalate ", " (map packageNameString candidates)+            ]+        Just loc -> pure $ Right (loc, packageLocationIdent loc)++    toLocSnapshot :: RawSnapshot -> PackageName -> RIO env (Either String (PackageLocationImmutable, PackageIdentifier))+    toLocSnapshot snapshot name =+        case Map.lookup name (rsPackages snapshot) of+          Nothing ->+            pure $ Left $ "Package does not appear in snapshot: " ++ packageNameString name+          Just sp -> do+            loc <- completePackageLocation (rspLocation sp)+            pure $ Right (loc, packageLocationIdent loc)++    -- Possible future enhancement: parse names as name + version range+    parse s =+        case parsePackageName (T.unpack t) of+            Just x -> Right $ Left x+            Nothing ->+                case parsePackageIdentifierRevision t of+                    Right x -> Right $ Right x+                    Left _ -> Left $ "Could not parse as package name or identifier: " ++ s+      where+        t = T.pack s
src/Stack/Upgrade.hs view
@@ -1,11 +1,8 @@ {-# LANGUAGE NoImplicitPrelude     #-}-{-# LANGUAGE CPP                   #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE TemplateHaskell       #-} module Stack.Upgrade     ( upgrade     , UpgradeOpts@@ -13,9 +10,6 @@     ) where  import           Stack.Prelude               hiding (force, Display (..))-import qualified Data.HashMap.Strict         as HashMap-import qualified Data.List-import qualified Data.Map                    as Map import qualified Data.Text as T import           Distribution.Version        (mkVersion') import           Lens.Micro                  (set)@@ -23,23 +17,14 @@ import           Path import qualified Paths_stack as Paths import           Stack.Build-import           Stack.Config--- Following import is redundant on non-Windows operating systems-#ifdef WINDOWS-import           Stack.DefaultColorWhen (defaultColorWhen)-#endif-import           Stack.Fetch-import           Stack.PackageIndex-import           Stack.PrettyPrint+import           Stack.Build.Target (NeedTargets(..))+import           Stack.Constants+import           Stack.Runners import           Stack.Setup-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageIndex-import           Stack.Types.PackageName-import           Stack.Types.Version import           Stack.Types.Config-import           Stack.Types.Resolver-import           System.Exit                 (ExitCode (ExitSuccess))+import           System.Console.ANSI (hSupportsANSIWithoutEmulation) import           System.Process              (rawSystem, readProcess)+import           RIO.PrettyPrint import           RIO.Process  upgradeOpts :: Parser UpgradeOpts@@ -104,13 +89,10 @@     }     deriving Show -upgrade :: HasConfig env-        => ConfigMonoid-        -> Maybe AbstractResolver-        -> Maybe String -- ^ git hash at time of building, if known+upgrade :: Maybe String -- ^ git hash at time of building, if known         -> UpgradeOpts-        -> RIO env ()-upgrade gConfigMonoid mresolver builtHash (UpgradeOpts mbo mso) =+        -> RIO Runner ()+upgrade 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@@ -130,10 +112,10 @@             source so   where     binary bo = binaryUpgrade bo-    source so = sourceUpgrade gConfigMonoid mresolver builtHash so+    source so = sourceUpgrade builtHash so -binaryUpgrade :: HasConfig env => BinaryOpts -> RIO env ()-binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) = do+binaryUpgrade :: BinaryOpts -> RIO Runner ()+binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) = withConfig NoReexec $ do     platforms0 <-       case mplatform of         Nothing -> preferredPlatforms@@ -157,9 +139,9 @@             Just downloadVersion -> do                 prettyInfoL                     [ flow "Current Stack version:"-                    , display stackVersion <> ","+                    , fromString (versionString stackVersion) <> ","                     , flow "available download version:"-                    , display downloadVersion+                    , fromString (versionString downloadVersion)                     ]                 return $ downloadVersion > stackVersion @@ -183,13 +165,10 @@                     $ throwString "Non-success exit code from running newly downloaded executable"  sourceUpgrade-  :: HasConfig env-  => ConfigMonoid-  -> Maybe AbstractResolver-  -> Maybe String+  :: Maybe String   -> SourceOpts-  -> RIO env ()-sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) =+  -> RIO Runner ()+sourceUpgrade builtHash (SourceOpts gitRepo) =   withSystemTempDir "stack-upgrade" $ \tmp -> do     mdir <- case gitRepo of       Just (repo, branch) -> do@@ -216,48 +195,50 @@                 -- --git" not working for earlier versions.                 let args = [ "clone", repo , "stack", "--depth", "1", "--recursive", "--branch", branch]                 withWorkingDir (toFilePath tmp) $ proc "git" args runProcess_-#ifdef WINDOWS                 -- On Windows 10, an upstream issue with the `git clone` command                 -- means that command clears, but does not then restore, the                 -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals.                 -- The folowing hack re-enables the lost ANSI-capability.-                _ <- liftIO defaultColorWhen-#endif-                return $ Just $ tmp </> $(mkRelDir "stack")-      Nothing -> do-        updateAllIndices-        PackageCache caches <- getPackageCaches-        let versions-                = filter (/= $(mkVersion "9.9.9")) -- Mistaken upload to Hackage, just ignore it-                $ maybe [] HashMap.keys-                $ HashMap.lookup $(mkPackageName "stack") caches--        when (null versions) (throwString "No stack found in package indices")+                when osIsWindows $+                  void $ liftIO $ hSupportsANSIWithoutEmulation stdout+                return $ Just $ tmp </> relDirStackProgName+      -- We need to access the Pantry database to find out about the+      -- latest Stack available on Hackage. We first use a standard+      -- Config to do this, and once we have the source load up the+      -- stack.yaml from inside that source.+      Nothing -> withConfig NoReexec $ do+        void $ updateHackageIndex+             $ Just "Updating index to make sure we find the latest Stack version"+        mversion <- getLatestHackageVersion YesRequireHackageIndex "stack" UsePreferredVersions+        (PackageIdentifierRevision _ version _) <-+          case mversion of+            Nothing -> throwString "No stack found in package indices"+            Just version -> pure version -        let version = Data.List.maximum versions-        if version <= fromCabalVersion (mkVersion' Paths.version)+        if version <= mkVersion' Paths.version             then do                 prettyInfoS "Already at latest version, no upgrade required"                 return Nothing             else do-                let ident = PackageIdentifier $(mkPackageName "stack") version-                paths <- unpackPackageIdents tmp Nothing-                    -- accept latest cabal revision-                    [PackageIdentifierRevision ident CFILatest]-                case Map.lookup ident paths of-                    Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found"-                    Just path -> return $ Just path+                suffix <- parseRelDir $ "stack-" ++ versionString version+                let dir = tmp </> suffix+                mrev <- getLatestHackageRevision YesRequireHackageIndex "stack" version+                case mrev of+                  Nothing -> throwString "Latest version with no revision"+                  Just (_rev, cfKey, treeKey) -> do+                    let ident = PackageIdentifier "stack" version+                    unpackPackageLocation dir $ PLIHackage ident cfKey treeKey+                    pure $ Just dir -    forM_ mdir $ \dir -> do-        lc <- loadConfig-            gConfigMonoid-            mresolver-            (SYLOverride $ dir </> $(mkRelFile "stack.yaml"))-        bconfig <- liftIO $ lcLoadBuildConfig lc Nothing-        envConfig1 <- runRIO bconfig $ setupEnv $ Just $-            "Try rerunning with --install-ghc to install the correct GHC into " <>-            T.pack (toFilePath (configLocalPrograms (view configL bconfig)))-        runRIO (set (buildOptsL.buildOptsInstallExesL) True envConfig1) $-            build (const $ return ()) Nothing defaultBuildOptsCLI-                { boptsCLITargets = ["stack"]-                }+    let modifyGO dir go = go+          { globalResolver = Nothing -- always use the resolver settings in the stack.yaml file+          , globalStackYaml = SYLOverride $ dir </> stackDotYaml+          }+        boptsCLI = defaultBuildOptsCLI+          { boptsCLITargets = ["stack"]+          }+    forM_ mdir $ \dir ->+      local (over globalOptsL (modifyGO dir)) $+      withConfig NoReexec $ withEnvConfig AllowNoTargets boptsCLI $+      local (set (buildOptsL.buildOptsInstallExesL) True) $+      build Nothing
src/Stack/Upload.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} -- | Provide ability to upload tarballs to Hackage. module Stack.Upload     ( -- * Upload@@ -12,14 +13,16 @@       -- * Credentials     , HackageCreds     , loadCreds+    , writeFilePrivate     ) where  import           Stack.Prelude import           Data.Aeson                            (FromJSON (..),                                                         ToJSON (..),-                                                        decode', encode,+                                                        decode', toEncoding, fromEncoding,                                                         object, withObject,                                                         (.:), (.=))+import           Data.ByteString.Builder               (lazyByteString) import qualified Data.ByteString.Char8                 as S import qualified Data.ByteString.Lazy                  as L import qualified Data.Conduit.Binary                   as CB@@ -34,13 +37,11 @@                                                         applyDigestAuth,                                                         displayDigestAuthException) import           Stack.Types.Config-import           Stack.Types.PackageIdentifier         (PackageIdentifier, packageIdentifierString,-                                                        packageIdentifierName)-import           Stack.Types.PackageName               (packageNameString) import           System.Directory                      (createDirectoryIfMissing,-                                                        removeFile)-import           System.FilePath                       ((</>), takeFileName)+                                                        removeFile, renameFile)+import           System.FilePath                       ((</>), takeFileName, takeDirectory) import           System.IO                             (stdout, putStrLn, putStr, print) -- TODO remove putStrLn, use logInfo+import           System.PosixCompat.Files              (setFileMode)  -- | Username and password to log into Hackage. --@@ -70,9 +71,13 @@ loadCreds config = do   fp <- credsFile config   elbs <- tryIO $ L.readFile fp-  case either (const Nothing) Just elbs >>= decode' of+  case either (const Nothing) Just elbs >>= \lbs -> (lbs, ) <$> decode' lbs of     Nothing -> fromPrompt fp-    Just mkCreds -> do+    Just (lbs, mkCreds) -> do+      -- Ensure privacy, for cleaning up old versions of Stack that+      -- didn't do this+      writeFilePrivate fp $ lazyByteString lbs+       unless (configSaveHackageCreds config) $ do         putStrLn "WARNING: You've set save-hackage-creds to false"         putStrLn "However, credentials were found at:"@@ -93,12 +98,34 @@           "Save hackage credentials to file at " ++ fp ++ " [y/n]? "         putStrLn "NOTE: Avoid this prompt in the future by using: save-hackage-creds: false"         when shouldSave $ do-          L.writeFile fp (encode hc)+          writeFilePrivate fp $ fromEncoding $ toEncoding hc           putStrLn "Saved!"           hFlush stdout        return hc +-- | Write contents to a file which is always private.+--+-- For history of this function, see:+--+-- * https://github.com/commercialhaskell/stack/issues/2159#issuecomment-477948928+--+-- * https://github.com/commercialhaskell/stack/pull/4665+writeFilePrivate :: MonadIO m => FilePath -> Builder -> m ()+writeFilePrivate fp builder = liftIO $ withTempFile (takeDirectory fp) (takeFileName fp) $ \fpTmp h -> do+  -- Temp file is created such that only current user can read and write it.+  -- See docs for openTempFile: https://www.stackage.org/haddock/lts-13.14/base-4.12.0.0/System-IO.html#v:openTempFile++  -- Write to the file and close the handle.+  hPutBuilder h builder+  hClose h++  -- Make sure the destination file, if present, is writeable+  void $ tryIO $ setFileMode fp 0o600++  -- And atomically move+  renameFile fpTmp fp+ credsFile :: Config -> IO FilePath credsFile config = do     let dir = toFilePath (view stackRootL config) </> "upload"@@ -178,13 +205,13 @@                -> PackageIdentifier                -> L.ByteString                -> IO ()-uploadRevision baseUrl creds ident cabalFile = do+uploadRevision baseUrl creds ident@(PackageIdentifier name _) cabalFile = do   req0 <- parseRequest $ concat     [ baseUrl     , "package/"     , packageIdentifierString ident     , "/"-    , packageNameString $ packageIdentifierName ident+    , packageNameString name     , ".cabal/edit"     ]   req1 <- formDataBody
+ src/System/Process/Pager.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, DeriveDataTypeable #-}++-- | Run external pagers (@$PAGER@, @less@, @more@).+module System.Process.Pager+  (pageWriter+  ,pageText+  ,PagerException(..))+  where++import Stack.Prelude+import System.Directory (findExecutable)+import System.Environment (lookupEnv)+import System.Process (createProcess,shell,waitForProcess,StdStream (CreatePipe)+                      ,CreateProcess(std_in, close_fds, delegate_ctlc))+import System.IO (stdout)+import qualified Data.Text.IO as T++-- | Run pager, providing a function that writes to the pager's input.+pageWriter :: (Handle -> IO ()) -> IO ()+pageWriter writer =+  do mpager <- lookupEnv "PAGER" `orElse`+               findExecutable "less" `orElse`+               findExecutable "more"+     case mpager of+       Just pager ->+         do (Just h,_,_,procHandle) <- createProcess (shell pager)+                                                       {std_in = CreatePipe+                                                       ,close_fds = True+                                                       ,delegate_ctlc = True}+            (_::Either IOException ()) <- try (do writer h+                                                  hClose h)+            exit <- waitForProcess procHandle+            case exit of+              ExitSuccess -> return ()+              ExitFailure n -> throwIO (PagerExitFailure pager n)+            return ()+       Nothing -> writer stdout+  where+    orElse a b = maybe b (return . Just) =<< a++-- | Run pager to display a 'Text'+pageText :: Text -> IO ()+pageText = pageWriter . flip T.hPutStr++-- | Exception running pager.+data PagerException = PagerExitFailure FilePath Int+  deriving Typeable+instance Show PagerException where+  show (PagerExitFailure p n) = "Pager (`" ++ p ++ "') exited with non-zero status: " ++ show n+instance Exception PagerException
− src/System/Process/PagerEditor.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables, RankNTypes, DeriveDataTypeable #-}---- | Run external pagers (@$PAGER@, @less@, @more@) and editors (@$VISUAL@,--- @$EDITOR@, @nano@, @pico@, @vi@).-module System.Process.PagerEditor-  (-- * Pager-   pageWriter-  ,pageByteString-  ,pageText-  ,pageBuilder-  ,pageFile-  ,pageString-  ,PagerException(..)-   -- * Editor-  ,editFile-  ,editReaderWriter-  ,editByteString-  ,editString-  ,EditorException(..))-  where--import qualified Data.ByteString.Lazy (readFile)-import Data.ByteString.Lazy (hPut)-import Stack.Prelude-import System.Directory (findExecutable)-import System.Environment (lookupEnv)-import System.Exit (ExitCode(..))-import System.FilePath ((</>))-import System.Process (createProcess,shell,proc,waitForProcess,StdStream (CreatePipe)-                      ,CreateProcess(std_in, close_fds, delegate_ctlc))-import System.IO (hPutStr,readFile,stdout)-import qualified Data.Text.IO as T---- | Run pager, providing a function that writes to the pager's input.-pageWriter :: (Handle -> IO ()) -> IO ()-pageWriter writer =-  do mpager <- lookupEnv "PAGER" `orElse`-               findExecutable "less" `orElse`-               findExecutable "more"-     case mpager of-       Just pager ->-         do (Just h,_,_,procHandle) <- createProcess (shell pager)-                                                       {std_in = CreatePipe-                                                       ,close_fds = True-                                                       ,delegate_ctlc = True}-            (_::Either IOException ()) <- try (do writer h-                                                  hClose h)-            exit <- waitForProcess procHandle-            case exit of-              ExitSuccess -> return ()-              ExitFailure n -> throwIO (PagerExitFailure pager n)-            return ()-       Nothing -> writer stdout---- | Run pager to display a lazy ByteString.-pageByteString :: LByteString -> IO ()-pageByteString = pageWriter . flip hPut---- | Run pager to display a 'Text'-pageText :: Text -> IO ()-pageText = pageWriter . flip T.hPutStr---- | Run pager to display a ByteString-Builder.-pageBuilder :: Builder -> IO ()-pageBuilder = pageWriter . flip hPutBuilder---- | Run pager to display contents of a file.-pageFile :: FilePath -> IO ()-pageFile p = pageByteString =<< Data.ByteString.Lazy.readFile p---- | Run pager to display a string.-pageString :: String -> IO ()-pageString = pageBuilder . fromString---- | Run editor to edit a file.-editFile :: FilePath -> IO ()-editFile path =-  do meditor <- lookupEnv "VISUAL" `orElse`-                lookupEnv "EDITOR" `orElse`-                findExecutable "nano" `orElse`-                findExecutable "pico" `orElse`-                findExecutable "vi"-     case meditor of-       Just editor ->-         do (_,_,_,procHandle) <- createProcess (proc "sh" ["-c", editor ++ " \"$1\"", "sh", path])-                                                  {close_fds = True,delegate_ctlc = True}-            exitCode <- waitForProcess procHandle-            case exitCode of-               ExitSuccess -> return ()-               ExitFailure n -> throwIO (EditorExitFailure editor n)-       Nothing -> throwIO EditorNotFound---- | Run editor, providing functions to write and read the file contents.-editReaderWriter :: forall a. String -> (Handle -> IO ()) -> (FilePath -> IO a) -> IO a-editReaderWriter filename writer reader =-  withSystemTempDirectory ""-                          (\p -> do let p' = p </> filename-                                    withFile p' WriteMode writer-                                    editFile p'-                                    reader p')---- | Run editor on a ByteString.-editByteString :: String -> LByteString -> IO LByteString-editByteString f s = editReaderWriter f (`hPut` s) Data.ByteString.Lazy.readFile---- | Run editor on a String.-editString :: String -> String -> IO String-editString f s = editReaderWriter f (`hPutStr` s) System.IO.readFile---- | Short-circuit first Just.-orElse :: (Monad m) => m (Maybe a) -> m (Maybe a) -> m (Maybe a)-orElse a b = do m <- a-                case m of-                  Just _ -> return m-                  Nothing -> b---- | Exception running pager.-data PagerException = PagerNotFound-                    | PagerExitFailure FilePath Int-  deriving Typeable-instance Show PagerException where-  show PagerNotFound = "No pager found (tried $PAGER, `less`, and `more`.)"-  show (PagerExitFailure p n) = "Pager (`" ++ p ++ "') exited with non-zero status: " ++ show n-instance Exception PagerException---- | Exception running editor.-data EditorException = EditorNotFound-                     | EditorExitFailure FilePath Int-  deriving Typeable-instance Show EditorException where-  show EditorNotFound = "No editor found (tried $VISUAL, $PAGER, `nano`, `pico`, and `vi`.)"-  show (EditorExitFailure p n) = "Editor (`" ++ p ++ "') exited with non-zero status: " ++ show n-instance Exception EditorException
− src/Text/PrettyPrint/Leijen/Extended.hs 
@@ -1,315 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}--- | This module re-exports some of the interface for--- "Text.PrettyPrint.Annotated.Leijen" along with additional definitions--- useful for stack.------ It defines a 'Monoid' instance for 'Doc'.-module Text.PrettyPrint.Leijen.Extended-  (-  -- * Pretty-print typeclass-  Display(..),--  -- * Ansi terminal Doc-  ---  -- See "System.Console.ANSI" for 'SGR' values to use beyond the colors-  -- provided.-  AnsiDoc, AnsiAnn(..), HasAnsiAnn(..),-  hDisplayAnsi, displayAnsi, displayPlain, renderDefault,--  -- ** Color combinators-  black, red, green, yellow, blue, magenta, cyan, white,-  dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite,-  onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite,-  ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite,--  -- ** Intensity combinators-  bold, faint, normal,--  -- * Selective re-exports from "Text.PrettyPrint.Annotated.Leijen"-  ---  -- Documentation of omissions up-to-date with @annotated-wl-pprint-0.7.0@--  -- ** Documents, parametrized by their annotations-  ---  -- Omitted compared to original: @putDoc, hPutDoc@-  Doc,--  -- ** Basic combinators-  ---  -- Omitted compared to original: @empty, char, text, (<>)@-  ---  -- Instead of @text@ and @char@, use 'fromString'.-  ---  -- Instead of @empty@, use 'mempty'.-  nest, line, linebreak, group, softline, softbreak,--  -- ** Alignment-  ---  -- The combinators in this section can not be described by Wadler's-  -- original combinators. They align their output relative to the-  -- current output position - in contrast to @nest@ which always-  -- aligns to the current nesting level. This deprives these-  -- combinators from being \`optimal\'. In practice however they-  -- prove to be very useful. The combinators in this section should-  -- be used with care, since they are more expensive than the other-  -- combinators. For example, @align@ shouldn't be used to pretty-  -- print all top-level declarations of a language, but using @hang@-  -- for let expressions is fine.-  ---  -- Omitted compared to original: @list, tupled, semiBraces@-  align, hang, indent, encloseSep,--  -- ** Operators-  ---  -- Omitted compared to original: @(<$>), (</>), (<$$>), (<//>)@-  (<+>),--  -- ** List combinators-  hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate,--  -- ** Fillers-  fill, fillBreak,--  -- ** Bracketing combinators-  enclose, squotes, dquotes, parens, angles, braces, brackets,--  -- ** Character documents-  -- Entirely omitted:-  ---  -- @-  -- lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket,-  -- squote, dquote, semi, colon, comma, space, dot, backslash, equals,-  -- pipe-  -- @--  -- ** Primitive type documents-  -- Entirely omitted:-  ---  -- @-  -- string, int, integer, float, double, rational, bool,-  -- @--  -- ** Semantic annotations-  annotate, noAnnotate,--  -- ** Rendering-  -- Original entirely omitted:-  -- @-  -- SimpleDoc(..), renderPretty, renderCompact, displayDecorated, displayDecoratedA, display, displayS, displayIO,-  -- SpanList(..), displaySpans-  -- @--  -- ** Undocumented-  -- Entirely omitted:-  -- @-  -- column, nesting, width-  -- @-  ) where--import Control.Monad.Reader (runReader, local)-import qualified Data.Map.Strict as M-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.Text.Lazy as LT-import qualified Data.Text.Lazy.Builder as LTB-import Stack.Prelude hiding (Display (..))-import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), ConsoleIntensity(..), SGR(..), setSGRCode, hSupportsANSI)-import qualified Text.PrettyPrint.Annotated.Leijen as P-import Text.PrettyPrint.Annotated.Leijen hiding ((<>), display)---- TODO: consider smashing together the code for wl-annotated-pprint and--- wl-pprint-text. The code here already handles doing the--- ansi-wl-pprint stuff (better!) atop wl-annotated-pprint. So the--- result would be a package unifying 3 different wl inspired packages.------ Perhaps it can still have native string support, by adding a type--- parameter to Doc?--instance Semigroup (Doc a) where-    (<>) = (P.<>)-instance Monoid (Doc a) where-    mappend = (<>)-    mempty = empty------------------------------------------------------------------------------------- Pretty-Print class--class Display a where-    type Ann a-    type Ann a = AnsiAnn-    display :: a -> Doc (Ann a)-    default display :: Show a => a -> Doc (Ann a)-    display = fromString . show--instance Display (Doc a) where-    type Ann (Doc a) = a-    display = id-------------------------------------------------------------------------------------- Ansi Doc--type AnsiDoc = Doc AnsiAnn--newtype AnsiAnn = AnsiAnn [SGR]-    deriving (Eq, Show, Semigroup, Monoid)--class HasAnsiAnn a where-    getAnsiAnn :: a -> AnsiAnn-    toAnsiDoc :: Doc a -> AnsiDoc-    toAnsiDoc = fmap getAnsiAnn--instance HasAnsiAnn AnsiAnn where-    getAnsiAnn = id-    toAnsiDoc = id--instance HasAnsiAnn () where-    getAnsiAnn _ = mempty--displayPlain :: Display a => Int -> a -> T.Text-displayPlain w = LT.toStrict . displayAnsiSimple . renderDefault w . fmap (const mempty) . display---- TODO: tweak these settings more?--- TODO: options for settings if this is released as a lib--renderDefault :: Int -> Doc a -> SimpleDoc a-renderDefault = renderPretty 1--displayAnsi :: (Display a, HasAnsiAnn (Ann a)) => Int -> a -> T.Text-displayAnsi w = LT.toStrict . displayAnsiSimple . renderDefault w . toAnsiDoc . display--hDisplayAnsi-    :: (Display a, HasAnsiAnn (Ann a), MonadIO m)-    => Handle -> Int -> a -> m ()-hDisplayAnsi h w x = liftIO $ do-    useAnsi <- hSupportsANSI h-    T.hPutStr h $ if useAnsi then displayAnsi w x else displayPlain w x--displayAnsiSimple :: SimpleDoc AnsiAnn -> LT.Text-displayAnsiSimple doc =-     LTB.toLazyText $ flip runReader mempty $ displayDecoratedWrap go doc-  where-    go (AnsiAnn sgrs) inner = do-        old <- ask-        let sgrs' = mapMaybe (\sgr -> if sgr == Reset then Nothing else Just (getSGRTag sgr, sgr)) sgrs-            new = if Reset `elem` sgrs-                      then M.fromList sgrs'-                      else foldl' (\mp (tag, sgr) -> M.insert tag sgr mp) old sgrs'-        (extra, contents) <- local (const new) inner-        return (extra, transitionCodes old new <> contents <> transitionCodes new old)-    transitionCodes old new =-        case (null removals, null additions) of-            (True, True) -> mempty-            (True, False) -> fromString (setSGRCode additions)-            (False, _) -> fromString (setSGRCode (Reset : M.elems new))-      where-        (removals, additions) = partitionEithers $ M.elems $-            M.mergeWithKey-               (\_ o n -> if o == n then Nothing else Just (Right n))-               (fmap Left)-               (fmap Right)-               old-               new--displayDecoratedWrap-    :: forall a m. Monad m-    => (forall b. a -> m (b, LTB.Builder) -> m (b, LTB.Builder))-    -> SimpleDoc a-    -> m LTB.Builder-displayDecoratedWrap f doc = do-    (mafter, result) <- go doc-    case mafter of-      Just _ -> error "Invariant violated by input to displayDecoratedWrap: no matching SAnnotStart for SAnnotStop."-      Nothing -> return result-  where-    spaces n = LTB.fromText (T.replicate n " ")--    go :: SimpleDoc a -> m (Maybe (SimpleDoc a), LTB.Builder)-    go SEmpty = return (Nothing, mempty)-    go (SChar c x) = liftM (fmap (LTB.singleton c <>)) (go x)-    -- NOTE: Could actually use the length to guess at an initial-    -- allocation.  Better yet would be to just use Text in pprint..-    go (SText _l s x) = liftM (fmap (fromString s <>)) (go x)-    go (SLine n x) = liftM (fmap ((LTB.singleton '\n' <>) . (spaces n <>))) (go x)-    go (SAnnotStart ann x) = do-        (mafter, contents) <- f ann (go x)-        case mafter of-            Just after -> liftM (fmap (contents <>)) (go after)-            Nothing -> error "Invariant violated by input to displayDecoratedWrap: no matching SAnnotStop for SAnnotStart."-    go (SAnnotStop x) = return (Just x, mempty)---- Foreground color combinators--black, red, green, yellow, blue, magenta, cyan, white,-    dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite,-    onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite,-    ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite-    :: Doc AnsiAnn -> Doc AnsiAnn-(black, dullblack, onblack, ondullblack) = colorFunctions Black-(red, dullred, onred, ondullred) = colorFunctions Red-(green, dullgreen, ongreen, ondullgreen) = colorFunctions Green-(yellow, dullyellow, onyellow, ondullyellow) = colorFunctions Yellow-(blue, dullblue, onblue, ondullblue) = colorFunctions Blue-(magenta, dullmagenta, onmagenta, ondullmagenta) = colorFunctions Magenta-(cyan, dullcyan, oncyan, ondullcyan) = colorFunctions Cyan-(white, dullwhite, onwhite, ondullwhite) = colorFunctions White--type EndoAnsiDoc = Doc AnsiAnn -> Doc AnsiAnn--colorFunctions :: Color -> (EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc)-colorFunctions color =-    ( ansiAnn [SetColor Foreground Vivid color]-    , ansiAnn [SetColor Foreground Dull color]-    , ansiAnn [SetColor Background Vivid color]-    , ansiAnn [SetColor Background Dull color]-    )--ansiAnn :: [SGR] -> Doc AnsiAnn -> Doc AnsiAnn-ansiAnn = annotate . AnsiAnn---- Intensity combinators--bold, faint, normal :: Doc AnsiAnn -> Doc AnsiAnn-bold = ansiAnn [SetConsoleIntensity BoldIntensity]-faint = ansiAnn [SetConsoleIntensity FaintIntensity]-normal = ansiAnn [SetConsoleIntensity NormalIntensity]---- | Tags for each field of state in SGR (Select Graphics Rendition).------ It's a bit of a hack that 'TagReset' is included.-data SGRTag-    = TagReset-    | TagConsoleIntensity-    | TagItalicized-    | TagUnderlining-    | TagBlinkSpeed-    | TagVisible-    | TagSwapForegroundBackground-    | TagColorForeground-    | TagColorBackground-    | TagRGBColor-    deriving (Eq, Ord)--getSGRTag :: SGR -> SGRTag-getSGRTag Reset{}                       = TagReset-getSGRTag SetConsoleIntensity{}         = TagConsoleIntensity-getSGRTag SetItalicized{}               = TagItalicized-getSGRTag SetUnderlining{}              = TagUnderlining-getSGRTag SetBlinkSpeed{}               = TagBlinkSpeed-getSGRTag SetVisible{}                  = TagVisible-getSGRTag SetSwapForegroundBackground{} = TagSwapForegroundBackground-getSGRTag (SetColor Foreground _ _)     = TagColorForeground-getSGRTag (SetColor Background _ _)     = TagColorBackground-getSGRTag SetRGBColor{}                 = TagRGBColor
+ src/main/BuildInfo.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++#ifdef USE_GIT_INFO+{-# LANGUAGE TemplateHaskell #-}+#endif++-- Extracted from Main so that the Main module does not use CPP or TH,+-- and therefore doesn't need to be recompiled as often.+module BuildInfo+  ( versionString'+  , maybeGitHash+  , hpackVersion+  ) where++import Stack.Prelude+import qualified Paths_stack as Meta+import qualified Distribution.Text as Cabal (display)+import           Distribution.System (buildArch)++#ifndef HIDE_DEP_VERSIONS+import qualified Build_stack+#endif++#ifdef USE_GIT_INFO+import           GitHash (giCommitCount, giHash, tGitInfoCwdTry)+#endif++#ifdef USE_GIT_INFO+import           Options.Applicative.Simple (simpleVersion)+#endif++#ifdef USE_GIT_INFO+import           Data.Version (versionBranch)+#else+import           Data.Version (showVersion, versionBranch)+#endif++versionString' :: String+#ifdef USE_GIT_INFO+versionString' = concat $ concat+    [ [$(simpleVersion Meta.version)]+      -- Leave out number of commits for --depth=1 clone+      -- See https://github.com/commercialhaskell/stack/issues/792+    , case giCommitCount <$> $$tGitInfoCwdTry of+        Left _ -> []+        Right 1 -> []+        Right count -> [" (", show count, " commits)"]+    , [afterVersion]+    ]+#else+versionString' = showVersion Meta.version ++ afterVersion+#endif+  where+    afterVersion = concat+      [ preReleaseString+      , ' ' : Cabal.display buildArch+      , depsString+      , warningString+      ]+    preReleaseString =+      case versionBranch Meta.version of+        (_:y:_) | even y -> " PRE-RELEASE"+        (_:_:z:_) | even z -> " RELEASE-CANDIDATE"+        _ -> ""+#ifdef HIDE_DEP_VERSIONS+    depsString = " hpack-" ++ VERSION_hpack+#else+    depsString = "\nCompiled with:\n" ++ unlines (map ("- " ++) Build_stack.deps)+#endif+#ifdef SUPPORTED_BUILD+    warningString = ""+#else+    warningString = unlines+      [ ""+      , "Warning: this is an unsupported build that may use different versions of"+      , "dependencies and GHC than the officially released binaries, and therefore may"+      , "not behave identically.  If you encounter problems, please try the latest"+      , "official build by running 'stack upgrade --force-download'."+      ]+#endif++-- | If USE_GIT_INFO is enabled, the Git hash in the build directory, otherwise Nothing.+maybeGitHash :: Maybe String+maybeGitHash =+#ifdef USE_GIT_INFO+        (either (const Nothing) (Just . giHash) $$tGitInfoCwdTry)+#else+        Nothing+#endif++-- | Hpack version we're compiled against+hpackVersion :: String+hpackVersion = VERSION_hpack
src/main/Main.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}@@ -7,68 +6,55 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} -#ifdef USE_GIT_INFO-{-# LANGUAGE TemplateHaskell #-}-#endif- -- | Main stack tool entry point.  module Main (main) where -#ifndef HIDE_DEP_VERSIONS-import qualified Build_stack-#endif+import           BuildInfo import           Stack.Prelude hiding (Display (..))+import           Conduit (runConduitRes, sourceLazy, sinkFileCautious) import           Control.Monad.Reader (local) import           Control.Monad.Trans.Except (ExceptT) import           Control.Monad.Writer.Lazy (Writer) import           Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping)) import           Data.Attoparsec.Interpreter (getInterpreterArgs)-import qualified Data.ByteString.Lazy as L-import           Data.IORef.RunOnce (runOnce) import           Data.List import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T import           Data.Version (showVersion) import           RIO.Process-#ifdef USE_GIT_INFO-import           GitHash (giCommitCount, giHash, tGitInfoCwdTry)-#endif-import           Distribution.System (buildArch)-import qualified Distribution.Text as Cabal (display) import           Distribution.Version (mkVersion') import           GHC.IO.Encoding (mkTextEncoding, textEncodingName) import           Options.Applicative import           Options.Applicative.Help (errorHelp, stringChunk, vcatChunks) import           Options.Applicative.Builder.Extra import           Options.Applicative.Complicated-#ifdef USE_GIT_INFO-import           Options.Applicative.Simple (simpleVersion)-#endif import           Options.Applicative.Types (ParserHelp(..))+import           Pantry (loadSnapshot) import           Path import           Path.IO import qualified Paths_stack as Meta+import           RIO.PrettyPrint+import qualified RIO.PrettyPrint as PP (style) import           Stack.Build-import           Stack.Clean (CleanOpts(..), clean)+import           Stack.Build.Target (NeedTargets(..))+import           Stack.Clean (CleanCommand(..), CleanOpts(..), clean) import           Stack.Config import           Stack.ConfigCmd as ConfigCmd import           Stack.Constants import           Stack.Constants.Config import           Stack.Coverage-import           Stack.DefaultColorWhen (defaultColorWhen) import qualified Stack.Docker as Docker import           Stack.Dot import           Stack.GhcPkg (findGhcPkgField) import qualified Stack.Nix as Nix-import           Stack.Fetch import           Stack.FileWatch+import           Stack.Freeze import           Stack.Ghci import           Stack.Hoogle import           Stack.Ls import qualified Stack.IDE as IDE-import qualified Stack.Image as Image import           Stack.Init import           Stack.New import           Stack.Options.BuildParser@@ -78,37 +64,33 @@ import           Stack.Options.ExecParser import           Stack.Options.GhciParser import           Stack.Options.GlobalParser+import           Stack.Options.FreezeParser  import           Stack.Options.HpcReportParser import           Stack.Options.NewParser import           Stack.Options.NixParser import           Stack.Options.ScriptParser import           Stack.Options.SDistParser-import           Stack.Options.SolverParser import           Stack.Options.Utils-import qualified Stack.PackageIndex import qualified Stack.Path-import           Stack.PrettyPrint import           Stack.Runners import           Stack.Script import           Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball', SDistOpts(..))+import           Stack.Setup (withNewLocalBuildTargets) import           Stack.SetupCmd-import qualified Stack.Sig as Sig-import           Stack.Snapshot (loadResolver)-import           Stack.Solver (solveExtraDeps) import           Stack.Types.Version import           Stack.Types.Config-import           Stack.Types.Compiler import           Stack.Types.NamedComponent-import           Stack.Types.Nix+import           Stack.Types.SourceMap+import           Stack.Unpack import           Stack.Upgrade import qualified Stack.Upload as Upload import qualified System.Directory as D import           System.Environment (getProgName, getArgs, withArgs)-import           System.Exit-import           System.FilePath (isValid, pathSeparator)+import           System.FilePath (isValid, pathSeparator, takeDirectory) import qualified System.FilePath as FP-import           System.IO (stderr, stdin, stdout, BufferMode(..), hPutStrLn, hPrint, hGetEncoding, hSetEncoding)+import           System.IO (stderr, stdin, stdout, BufferMode(..), hPutStrLn, hGetEncoding, hSetEncoding)+import           System.Terminal (hIsTerminalDeviceOrMinTTY)  -- | Change the character encoding of the given Handle to transliterate -- on unsupported characters instead of throwing an exception@@ -122,44 +104,6 @@               hSetEncoding h enc'         _ -> return () -versionString' :: String-#ifdef USE_GIT_INFO-versionString' = concat $ concat-    [ [$(simpleVersion Meta.version)]-      -- Leave out number of commits for --depth=1 clone-      -- See https://github.com/commercialhaskell/stack/issues/792-    , case giCommitCount <$> $$tGitInfoCwdTry of-        Left _ -> []-        Right 1 -> []-        Right count -> [" (", show count, " commits)"]-    , [" ", Cabal.display buildArch]-    , [depsString, warningString]-    ]-#else-versionString' =-    showVersion Meta.version-    ++ ' ' : Cabal.display buildArch-    ++ depsString-    ++ warningString-#endif-  where-#ifdef HIDE_DEP_VERSIONS-    depsString = " hpack-" ++ VERSION_hpack-#else-    depsString = "\nCompiled with:\n" ++ unlines (map ("- " ++) Build_stack.deps)-#endif-#ifdef SUPPORTED_BUILD-    warningString = ""-#else-    warningString = unlines-      [ ""-      , "Warning: this is an unsupported build that may use different versions of"-      , "dependencies and GHC than the officially released binaries, and therefore may"-      , "not behave identically.  If you encounter problems, please try the latest"-      , "official build by running 'stack upgrade --force-download'."-      ]-#endif- main :: IO () main = do   -- Line buffer the output by default, particularly for non-terminal runs.@@ -175,7 +119,6 @@   -- On Windows, where applicable, defaultColorWhen has the side effect of   -- enabling ANSI for ANSI-capable native (ConHost) terminals, if not already   -- ANSI-enabled.-  defColorWhen <- defaultColorWhen   execExtraHelp args                 Docker.dockerHelpOptName                 (dockerOptsParser False)@@ -191,22 +134,22 @@     Left (exitCode :: ExitCode) ->       throwIO exitCode     Right (globalMonoid,run) -> do-      let global = globalOptsFromMonoid isTerminal defColorWhen globalMonoid+      global <- globalOptsFromMonoid isTerminal globalMonoid       when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString'       case globalReExecVersion global of           Just expectVersion -> do-              expectVersion' <- parseVersionFromString expectVersion-              unless (checkVersion MatchMinor expectVersion' (fromCabalVersion (mkVersion' Meta.version)))+              expectVersion' <- parseVersionThrowing expectVersion+              unless (checkVersion MatchMinor expectVersion' (mkVersion' Meta.version))                   $ throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)           _ -> return ()-      run global `catch` \e ->+      withRunnerGlobal global $ run `catch` \e ->           -- This special handler stops "stack: " from being printed before the           -- exception           case fromException e of-              Just ec -> System.Exit.exitWith ec+              Just ec -> exitWith ec               Nothing -> do-                  hPrint stderr e-                  System.Exit.exitFailure+                  logError $ fromString $ displayException e+                  exitFailure  -- Vertically combine only the error component of the first argument with the -- error component of the second.@@ -217,11 +160,11 @@   :: FilePath   -> String   -> Bool-  -> IO (GlobalOptsMonoid, GlobalOpts -> IO ())+  -> IO (GlobalOptsMonoid, RIO Runner ()) commandLineHandler currentDir progName isInterpreter = complicatedOptions-  Meta.version+  (mkVersion' Meta.version)   (Just versionString')-  VERSION_hpack+  hpackVersion   "stack - The Haskell Tool Stack"   ""   "stack's documentation is available at https://docs.haskellstack.org/"@@ -282,11 +225,10 @@                     newCmd                     newOptsParser         addCommand' "templates"-         (unwords [ "List the templates available for `stack new'."-                  , "Templates are drawn from"-                  , "https://github.com/commercialhaskell/stack-templates"-                  , "Note: `stack new' can also accept a template from a"-                  , "local file or a remote URL."+         (unwords [ "Show how to find templates available for `stack new'."+                  , "`stack new' can accept a template from a remote repository"+                  , "(default: github), local file or remote URL."+                  , "Note: this downloads the help file."                   ] )                     templatesCmd                     (pure ())@@ -294,20 +236,16 @@                     "Create stack project config from cabal or hpack package specifications"                     initCmd                     initOptsParser-        addCommand' "solver"-                    "Add missing extra-deps to stack project config"-                    solverCmd-                    solverOptsParser         addCommand' "setup"                     "Get the appropriate GHC for your project"                     setupCmd                     setupParser         addCommand' "path"                     "Print out handy path information"-                    pathCmd+                    Stack.Path.path                     Stack.Path.pathParser         addCommand' "ls"-                    "List command. (Supports snapshots and dependencies)"+                    "List command. (Supports snapshots, dependencies and stack's styles)"                     lsCmd                     lsParser         addCommand' "unpack"@@ -328,15 +266,15 @@             "upload"             "Upload a package to Hackage"             uploadCmd-            (sdistOptsParser True)+            sdistOptsParser         addCommand'             "sdist"             "Create source distribution tarballs"             sdistCmd-            (sdistOptsParser False)+            sdistOptsParser         addCommand' "dot"                     "Visualize your project's dependency graph using Graphviz dot"-                    dotCmd+                    dot                     (dotOptsParser False) -- Default for --external is False.         addCommand' "ghc"                     "Run ghc"@@ -386,10 +324,20 @@                   "Run runghc (alias for 'runghc')"                   execCmd                   (execOptsParser $ Just ExecRunGhc)-      addCommand' "script"-                  "Run a Stack Script"-                  scriptCmd-                  scriptOptsParser+      addCommand "script"+                 "Run a Stack Script"+                 globalFooter+                 scriptCmd+                 (\so gom ->+                    gom+                      { globalMonoidResolverRoot = First $ Just $ takeDirectory $ soFile so+                      })+                 (globalOpts OtherCmdGlobalOpts)+                 scriptOptsParser+      addCommand' "freeze"+                  "Show project or snapshot with pinned dependencies if there are any such (experimental, may be removed)"+                  freezeCmd+                  freezeOptsParser        unless isInterpreter (do         addCommand' "eval"@@ -397,13 +345,13 @@                     evalCmd                     (evalOptsParser "CODE")         addCommand' "clean"-                    "Clean the local packages"+                    "Delete build artefacts for the project packages."                     cleanCmd-                    cleanOptsParser-        addCommand' "list-dependencies"-                    "List the dependencies"-                    (listDependenciesCmd True)-                    listDepsOptsParser+                    (cleanOptsParser Clean)+        addCommand' "purge"+                    "Delete the project stack working directories (.stack-work by default). Shortcut for 'stack clean --full'"+                    cleanCmd+                    (cleanOptsParser Purge)         addCommand' "query"                     "Query general build information (experimental)"                     queryCmd@@ -411,16 +359,27 @@         addSubCommands'             "ide"             "IDE-specific commands"-            (do addCommand'+            (let outputFlag = flag+                   IDE.OutputLogInfo+                   IDE.OutputStdout+                   (long "stdout" <>+                    help "Send output to stdout instead of the default, stderr")+                 cabalFileFlag = flag+                   IDE.ListPackageNames+                   IDE.ListPackageCabalFiles+                   (long "cabal-files" <>+                    help "Print paths to package cabal-files instead of package names")+             in+             do addCommand'                     "packages"                     "List all available local loadable packages"                     idePackagesCmd-                    (pure ())+                    ((,) <$> outputFlag <*> cabalFileFlag)                 addCommand'                     "targets"                     "List all available stack targets"                     ideTargetsCmd-                    (pure ()))+                    outputFlag)         addSubCommands'           Docker.dockerCmdName           "Subcommands specific to Docker use"@@ -432,35 +391,19 @@                           "Reset the Docker sandbox"                           dockerResetCmd                           (switch (long "keep-home" <>-                                   help "Do not delete sandbox's home directory"))-              addCommand' Docker.dockerCleanupCmdName-                          "Clean up Docker images and containers"-                          dockerCleanupCmd-                          dockerCleanupOptsParser)+                                   help "Do not delete sandbox's home directory")))         addSubCommands'             ConfigCmd.cfgCmdName-            "Subcommands specific to modifying stack.yaml files"-            (addCommand' ConfigCmd.cfgCmdSetName-                        "Sets a field in the project's stack.yaml to value"-                        cfgSetCmd-                        configCmdSetParser)-        addSubCommands'-            Image.imgCmdName-            "Subcommands specific to imaging"-            (addCommand'-                 Image.imgDockerCmdName-                 "Build a Docker image for the project"-                 imgDockerCmd-                 ((,) <$>-                  boolFlags-                      True-                      "build"-                      "building the project before creating the container"-                      idm <*>-                  many-                      (textOption-                           (long "image" <>-                            help "A specific container image name to build"))))+            "Subcommands for accessing and modifying configuration values"+            (do+               addCommand' ConfigCmd.cfgCmdSetName+                          "Sets a field in the project's stack.yaml to value"+                          (withConfig NoReexec . cfgCmdSet)+                          configCmdSetParser+               addCommand' ConfigCmd.cfgCmdEnvName+                          "Print environment variables for use in a shell"+                          (withConfig YesReexec . withDefaultEnvConfig . cfgCmdEnv)+                          configCmdEnvParser)         addSubCommands'           "hpc"           "Subcommands specific to Haskell Program Coverage"@@ -471,10 +414,10 @@         )       where         -- addCommand hiding global options-        addCommand' :: String -> String -> (a -> GlobalOpts -> IO ()) -> Parser a+        addCommand' :: String -> String -> (a -> RIO Runner ()) -> Parser a                     -> AddCommand         addCommand' cmd title constr =-            addCommand cmd title globalFooter constr (globalOpts OtherCmdGlobalOpts)+            addCommand cmd title globalFooter constr (\_ gom -> gom) (globalOpts OtherCmdGlobalOpts)          addSubCommands' :: String -> String -> AddCommand                         -> AddCommand@@ -482,16 +425,16 @@             addSubCommands cmd title globalFooter (globalOpts OtherCmdGlobalOpts)          -- Additional helper that hides global options and shows build options-        addBuildCommand' :: String -> String -> (a -> GlobalOpts -> IO ()) -> Parser a+        addBuildCommand' :: String -> String -> (a -> RIO Runner ()) -> Parser a                          -> AddCommand         addBuildCommand' cmd title constr =-            addCommand cmd title globalFooter constr (globalOpts BuildCmdGlobalOpts)+            addCommand cmd title globalFooter constr (\_ gom -> gom) (globalOpts BuildCmdGlobalOpts)          -- Additional helper that hides global options and shows some ghci options-        addGhciCommand' :: String -> String -> (a -> GlobalOpts -> IO ()) -> Parser a+        addGhciCommand' :: String -> String -> (a -> RIO Runner ()) -> Parser a                          -> AddCommand         addGhciCommand' cmd title constr =-            addCommand cmd title globalFooter constr (globalOpts GhciCmdGlobalOpts)+            addCommand cmd title globalFooter constr (\_ gom -> gom) (globalOpts GhciCmdGlobalOpts)      globalOpts :: GlobalOptsContext -> Parser GlobalOptsMonoid     globalOpts kind =@@ -507,7 +450,7 @@     globalFooter = "Run 'stack --help' for global options that apply to all subcommands."  type AddCommand =-    ExceptT (GlobalOpts -> IO ()) (Writer (Mod CommandFields (GlobalOpts -> IO (), GlobalOptsMonoid))) ()+    ExceptT (RIO Runner ()) (Writer (Mod CommandFields (RIO Runner (), GlobalOptsMonoid))) ()  -- | fall-through to external executables in `git` style if they exist -- (i.e. `stack something` looks for `stack-something` before@@ -542,7 +485,7 @@   => FilePath   -> [String]   -> ParserFailure ParserHelp-  -> IO (GlobalOptsMonoid, (GlobalOpts -> IO (), t))+  -> IO (GlobalOptsMonoid, (RIO Runner (), t)) interpreterHandler currentDir args f = do   -- args can include top-level config such as --extra-lib-dirs=... (set by   -- nix-shell) - we need to find the first argument which is a file, everything@@ -595,181 +538,158 @@       (a,b) <- withArgs cmdArgs parseCmdLine       return (a,(b,mempty)) -pathCmd :: [Text] -> GlobalOpts -> IO ()-pathCmd keys go = withBuildConfig go (Stack.Path.path keys)--setupCmd :: SetupCmdOpts -> GlobalOpts -> IO ()-setupCmd sco@SetupCmdOpts{..} go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> do-  when (isJust scoUpgradeCabal && nixEnable (configNix (lcConfig lc))) $ do-    throwIO UpgradeCabalUnusable-  withUserFileLock go (view stackRootL lc) $ \lk -> do-    let getCompilerVersion = loadCompilerVersion go lc-    runRIO (lcConfig lc) $-      Docker.reexecWithOptionalContainer-          (lcProjectRoot lc)-          Nothing-          (runRIO (lcConfig lc) $-           Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion $ do-           (wantedCompiler, compilerCheck, mstack) <--               case scoCompilerVersion of-                   Just v -> return (v, MatchMinor, Nothing)-                   Nothing -> do-                       bc <- liftIO $ lcLoadBuildConfig lc globalCompiler-                       return ( view wantedCompilerVersionL bc-                              , configCompilerCheck (lcConfig lc)-                              , Just $ view stackYamlL bc-                              )-           runRIO (loadMiniConfig (lcConfig lc)) $ setup sco wantedCompiler compilerCheck mstack-           )-          Nothing-          (Just $ munlockFile lk)+setupCmd :: SetupCmdOpts -> RIO Runner ()+setupCmd sco@SetupCmdOpts{..} = withConfig YesReexec $ do+  (wantedCompiler, compilerCheck, mstack) <-+    case scoCompilerVersion of+      Just v -> return (v, MatchMinor, Nothing)+      Nothing -> withBuildConfig $ (,,)+        <$> view wantedCompilerVersionL+        <*> view (configL.to configCompilerCheck)+        <*> (Just <$> view stackYamlL)+  setup sco wantedCompiler compilerCheck mstack -cleanCmd :: CleanOpts -> GlobalOpts -> IO ()-cleanCmd opts go =-  -- See issues #2010 and #3468 for why "stack clean --full" is not used-  -- within docker.-  case opts of-    CleanFull{} -> withBuildConfigAndLockNoDocker go (const (clean opts))-    CleanShallow{} -> withBuildConfigAndLock go (const (clean opts))+cleanCmd :: CleanOpts -> RIO Runner ()+cleanCmd = withConfig NoReexec . withBuildConfig . clean  -- | Helper for build and install commands-buildCmd :: BuildOptsCLI -> GlobalOpts -> IO ()-buildCmd opts go = do+buildCmd :: BuildOptsCLI -> RIO Runner ()+buildCmd opts = do   when (any (("-prof" `elem`) . either (const []) id . parseArgs Escaping) (boptsCLIGhcOptions opts)) $ do-    hPutStrLn stderr "Error: When building with stack, you should not use the -prof GHC option"-    hPutStrLn stderr "Instead, please use --library-profiling and --executable-profiling"-    hPutStrLn stderr "See: https://github.com/commercialhaskell/stack/issues/1015"-    System.Exit.exitFailure-  case boptsCLIFileWatch opts of-    FileWatchPoll -> fileWatchPoll stderr inner-    FileWatch -> fileWatch stderr inner-    NoFileWatch -> inner $ const $ return ()+    logError "Error: When building with stack, you should not use the -prof GHC option"+    logError "Instead, please use --library-profiling and --executable-profiling"+    logError "See: https://github.com/commercialhaskell/stack/issues/1015"+    exitFailure+  local (over globalOptsL modifyGO) $+    case boptsCLIFileWatch opts of+      FileWatchPoll -> fileWatchPoll stderr (inner . Just)+      FileWatch -> fileWatch stderr (inner . Just)+      NoFileWatch -> inner Nothing   where-    inner setLocalFiles = withBuildConfigAndLock go' $ \lk ->-        Stack.Build.build setLocalFiles lk opts+    inner+      :: Maybe (Set (Path Abs File) -> IO ())+      -> RIO Runner ()+    inner setLocalFiles = withConfig YesReexec $ withEnvConfig NeedTargets opts $+        Stack.Build.build setLocalFiles     -- Read the build command from the CLI and enable it to run-    go' = case boptsCLICommand opts of-               Test -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) go-               Haddock -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidHaddockL) (Just True) go-               Bench -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) go-               Install -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidInstallExesL) (Just True) go-               Build -> go -- Default case is just Build+    modifyGO =+      case boptsCLICommand opts of+        Test -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True)+        Haddock -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidHaddockL) (Just True)+        Bench -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True)+        Install -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidInstallExesL) (Just True)+        Build -> id -- Default case is just Build -uninstallCmd :: [String] -> GlobalOpts -> IO ()-uninstallCmd _ go = withConfigAndLock go $+uninstallCmd :: [String] -> RIO Runner ()+uninstallCmd _ = do     prettyErrorL       [ flow "stack does not manage installations in global locations."       , flow "The only global mutation stack performs is executable copying."       , flow "For the default executable destination, please run"-      , styleShell "stack path --local-bin"+      , PP.style Shell "stack path --local-bin"       ]+    liftIO exitFailure  -- | Unpack packages to the filesystem-unpackCmd :: ([String], Maybe Text) -> GlobalOpts -> IO ()-unpackCmd (names, Nothing) go = unpackCmd (names, Just ".") go-unpackCmd (names, Just dstPath) go = withConfigAndLock go $ do-    mSnapshotDef <- mapM (makeConcreteResolver Nothing >=> loadResolver) (globalResolver go)-    Stack.Fetch.unpackPackages mSnapshotDef (T.unpack dstPath) names+unpackCmd :: ([String], Maybe Text) -> RIO Runner ()+unpackCmd (names, Nothing) = unpackCmd (names, Just ".")+unpackCmd (names, Just dstPath) = withConfig NoReexec $ do+    mresolver <- view $ globalOptsL.to globalResolver+    mSnapshot <- forM mresolver $ \resolver -> do+      concrete <- makeConcreteResolver resolver+      loc <- completeSnapshotLocation concrete+      loadSnapshot loc+    dstPath' <- resolveDir' $ T.unpack dstPath+    unpackPackages mSnapshot dstPath' names  -- | Update the package index-updateCmd :: () -> GlobalOpts -> IO ()-updateCmd () go = withConfigAndLock go Stack.PackageIndex.updateAllIndices+updateCmd :: () -> RIO Runner ()+updateCmd () = withConfig NoReexec (void (updateHackageIndex Nothing)) -upgradeCmd :: UpgradeOpts -> GlobalOpts -> IO ()-upgradeCmd upgradeOpts' go = withGlobalConfigAndLock go $-    upgrade (globalConfigMonoid go)-            (globalResolver go)-#ifdef USE_GIT_INFO-            (either (const Nothing) (Just . giHash) $$tGitInfoCwdTry)-#else-            Nothing-#endif-            upgradeOpts'+upgradeCmd :: UpgradeOpts -> RIO Runner ()+upgradeCmd upgradeOpts' = do+  go <- view globalOptsL+  case globalResolver go of+    Just _ -> do+      logError "You cannot use the --resolver option with the upgrade command"+      liftIO exitFailure+    Nothing ->+      withGlobalProject $+      upgrade+        maybeGitHash+        upgradeOpts'  -- | Upload to Hackage-uploadCmd :: SDistOpts -> GlobalOpts -> IO ()-uploadCmd (SDistOpts [] _ _ _ _ _ _) go =-    withConfigAndLock go . prettyErrorL $+uploadCmd :: SDistOpts -> RIO Runner ()+uploadCmd (SDistOpts [] _ _ _ _) = do+    prettyErrorL         [ flow "To upload the current package, please run"-        , styleShell "stack upload ."+        , PP.style Shell "stack upload ."         , flow "(with the period at the end)"         ]-uploadCmd sdistOpts go = do+    liftIO exitFailure+uploadCmd sdistOpts = do     let partitionM _ [] = return ([], [])         partitionM f (x:xs) = do             r <- f x             (as, bs) <- partitionM f xs             return $ if r then (x:as, bs) else (as, x:bs)-    (files, nonFiles) <- partitionM D.doesFileExist (sdoptsDirsToWorkWith sdistOpts)-    (dirs, invalid) <- partitionM D.doesDirectoryExist nonFiles-    withBuildConfigAndLock go $ \_ -> do+    (files, nonFiles) <- liftIO $ partitionM D.doesFileExist (sdoptsDirsToWorkWith sdistOpts)+    (dirs, invalid) <- liftIO $ partitionM D.doesDirectoryExist nonFiles+    withConfig YesReexec $ withDefaultEnvConfig $ do         unless (null invalid) $ do-            let invalidList = bulletedList $ map (styleFile . fromString) invalid+            let invalidList = bulletedList $ map (PP.style File . fromString) invalid             prettyErrorL-                [ styleShell "stack upload"+                [ PP.style Shell "stack upload"                 , flow "expects a list of sdist tarballs or package directories."                 , flow "Can't find:"                 , line <> invalidList                 ]-            liftIO System.Exit.exitFailure+            exitFailure         when (null files && null dirs) $ do             prettyErrorL-                [ styleShell "stack upload"+                [ PP.style Shell "stack upload"                 , flow "expects a list of sdist tarballs or package directories, but none were specified."                 ]-            liftIO System.Exit.exitFailure+            exitFailure         config <- view configL         let hackageUrl = T.unpack $ configHackageBaseUrl config-        getCreds <- liftIO (runOnce (Upload.loadCreds config))+        getCreds <- liftIO $ memoizeRef $ Upload.loadCreds config         mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files         forM_             files             (\file ->                   do tarFile <- resolveFile' file                      liftIO $ do-                       creds <- getCreds-                       Upload.upload hackageUrl creds (toFilePath tarFile)-                     when-                         (sdoptsSign sdistOpts)-                         (void $-                          Sig.sign-                              (sdoptsSignServerUrl sdistOpts)-                              tarFile))+                       creds <- runMemoized getCreds+                       Upload.upload hackageUrl creds (toFilePath tarFile))         unless (null dirs) $             forM_ dirs $ \dir -> do                 pkgDir <- resolveDir' dir                 (tarName, tarBytes, mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) pkgDir                 checkSDistTarball' sdistOpts tarName tarBytes                 liftIO $ do-                  creds <- getCreds+                  creds <- runMemoized getCreds                   Upload.uploadBytes hackageUrl creds tarName tarBytes                   forM_ mcabalRevision $ uncurry $ Upload.uploadRevision hackageUrl creds-                tarPath <- parseRelFile tarName-                when-                    (sdoptsSign sdistOpts)-                    (void $-                     Sig.signTarBytes-                         (sdoptsSignServerUrl sdistOpts)-                         tarPath-                         tarBytes) -sdistCmd :: SDistOpts -> GlobalOpts -> IO ()-sdistCmd sdistOpts go =-    withBuildConfig go $ do -- No locking needed.+sdistCmd :: SDistOpts -> RIO Runner ()+sdistCmd sdistOpts =+    withConfig YesReexec $ withDefaultEnvConfig $ do         -- If no directories are specified, build all sdist tarballs.         dirs' <- if null (sdoptsDirsToWorkWith sdistOpts)             then do-                dirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages+                dirs <- view $ buildConfigL.to (map ppRoot . Map.elems . smwProject . bcSMWanted)                 when (null dirs) $ do                     stackYaml <- view stackYamlL                     prettyErrorL-                        [ styleShell "stack sdist"+                        [ PP.style Shell "stack sdist"                         , flow "expects a list of targets, and otherwise defaults to all of the project's packages."                         , flow "However, the configuration at"-                        , display stackYaml+                        , pretty stackYaml                         , flow "contains no packages, so no sdist tarballs will be generated."                         ]-                    liftIO System.Exit.exitFailure+                    exitFailure                 return dirs             else mapM resolveDir' (sdoptsDirsToWorkWith sdistOpts)         forM_ dirs' $ \dir -> do@@ -777,11 +697,12 @@             distDir <- distDirFromDir dir             tarPath <- (distDir </>) <$> parseRelFile tarName             ensureDir (parent tarPath)-            liftIO $ L.writeFile (toFilePath tarPath) tarBytes-            prettyInfoL [flow "Wrote sdist tarball to", display tarPath]+            runConduitRes $+              sourceLazy tarBytes .|+              sinkFileCautious (toFilePath tarPath)+            prettyInfoL [flow "Wrote sdist tarball to", pretty tarPath]             checkSDistTarball sdistOpts tarPath             forM_ (sdoptsTarPath sdistOpts) $ copyTarToTarPath tarPath tarName-            when (sdoptsSign sdistOpts) (void $ Sig.sign (sdoptsSignServerUrl sdistOpts) tarPath)         where           copyTarToTarPath tarPath tarName targetDir = liftIO $ do             let targetTarPath = targetDir FP.</> tarName@@ -789,73 +710,52 @@             D.copyFile (toFilePath tarPath) targetTarPath  -- | Execute a command.-execCmd :: ExecOpts -> GlobalOpts -> IO ()-execCmd ExecOpts {..} go@GlobalOpts{..} =-    case eoExtra of-        ExecOptsPlain -> do-          loadConfigWithOpts go $ \lc ->-            withUserFileLock go (view stackRootL lc) $ \lk -> do-              let getCompilerVersion = loadCompilerVersion go lc-              runRIO (lcConfig lc) $-                Docker.reexecWithOptionalContainer-                    (lcProjectRoot lc)-                    -- Unlock before transferring control away, whether using docker or not:-                    (Just $ munlockFile lk)-                    (withBuildConfigAndLock go $ \buildLock -> do-                        config <- view configL-                        menv <- liftIO $ configProcessContextSettings config plainEnvSettings-                        withProcessContext menv $ do-                            (cmd, args) <- case (eoCmd, eoArgs) of-                                (ExecCmd cmd, args) -> return (cmd, args)-                                (ExecRun, args) -> getRunCmd args-                                (ExecGhc, args) -> return ("ghc", args)-                                (ExecRunGhc, args) -> return ("runghc", args)-                            munlockFile buildLock-                            Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (runRIO (lcConfig lc) $ exec cmd args))-                    Nothing-                    Nothing -- Unlocked already above.-        ExecOptsEmbellished {..} ->-            withBuildConfigAndLock go $ \lk -> do-              let targets = concatMap words eoPackages-              unless (null targets) $-                  Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI-                      { boptsCLITargets = map T.pack targets-                      }+execCmd :: ExecOpts -> RIO Runner ()+execCmd ExecOpts {..} =+  withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do+    unless (null targets) $ Stack.Build.build Nothing -              config <- view configL-              menv <- liftIO $ configProcessContextSettings config eoEnvSettings-              withProcessContext menv $ do-                -- Add RTS options to arguments-                let argsWithRts args = if null eoRtsOptions-                            then args :: [String]-                            else args ++ ["+RTS"] ++ eoRtsOptions ++ ["-RTS"]-                (cmd, args) <- case (eoCmd, argsWithRts eoArgs) of-                    (ExecCmd cmd, args) -> return (cmd, args)-                    (ExecRun, args) -> getRunCmd args-                    (ExecGhc, args) -> getGhcCmd "" eoPackages args-                    -- NOTE: This doesn't work for GHCJS, because it doesn't have-                    -- a runghcjs binary.-                    (ExecRunGhc, args) ->-                        getGhcCmd "run" eoPackages args-                munlockFile lk -- Unlock before transferring control away.+    config <- view configL+    menv <- liftIO $ configProcessContextSettings config eoEnvSettings+    withProcessContext menv $ do+      -- Add RTS options to arguments+      let argsWithRts args = if null eoRtsOptions+                  then args :: [String]+                  else args ++ ["+RTS"] ++ eoRtsOptions ++ ["-RTS"]+      (cmd, args) <- case (eoCmd, argsWithRts eoArgs) of+          (ExecCmd cmd, args) -> return (cmd, args)+          (ExecRun, args) -> getRunCmd args+          (ExecGhc, args) -> getGhcCmd eoPackages args+          -- NOTE: This doesn't work for GHCJS, because it doesn't have+          -- a runghcjs binary.+          (ExecRunGhc, args) -> getRunGhcCmd eoPackages args -                runWithPath eoCwd $ exec cmd args+      runWithPath eoCwd $ exec cmd args   where+      ExecOptsExtra {..} = eoExtra++      targets = concatMap words eoPackages+      boptsCLI = defaultBuildOptsCLI+                 { boptsCLITargets = map T.pack targets+                 }+       -- return the package-id of the first package in GHC_PACKAGE_PATH-      getPkgId wc name = do-          mId <- findGhcPkgField wc [] name "id"+      getPkgId name = do+          pkg <- getGhcPkgExe+          mId <- findGhcPkgField pkg [] name "id"           case mId of               Just i -> return (head $ words (T.unpack i))               -- should never happen as we have already installed the packages-              _      -> liftIO $ do-                  hPutStrLn stderr ("Could not find package id of package " ++ name)-                  System.Exit.exitFailure+              _      -> do+                  logError ("Could not find package id of package " <> fromString name)+                  exitFailure -      getPkgOpts wc pkgs =-          map ("-package-id=" ++) <$> mapM (getPkgId wc) pkgs+      getPkgOpts pkgs =+          map ("-package-id=" ++) <$> mapM getPkgId pkgs        getRunCmd args = do-          pkgComponents <- liftM (map lpvComponents . Map.elems . lpProject) getLocalPackages+          packages <- view $ buildConfigL.to (smwProject . bcSMWanted)+          pkgComponents <- for (Map.elems packages) ppComponents           let executables = filter isCExe $ concatMap Set.toList pkgComponents           let (exe, args') = case args of                              []   -> (firstExe, args)@@ -866,17 +766,22 @@                                 firstExe = listToMaybe executables           case exe of               Just (CExe exe') -> do-                Stack.Build.build (const (return ())) Nothing defaultBuildOptsCLI{boptsCLITargets = [T.cons ':' exe']}+                withNewLocalBuildTargets [T.cons ':' exe'] $ Stack.Build.build Nothing                 return (T.unpack exe', args')               _                -> do                   logError "No executables found."-                  liftIO System.Exit.exitFailure+                  exitFailure -      getGhcCmd prefix pkgs args = do-          wc <- view $ actualCompilerVersionL.whichCompilerL-          pkgopts <- getPkgOpts wc pkgs-          return (prefix ++ compilerExeName wc, pkgopts ++ args)+      getGhcCmd pkgs args = do+          pkgopts <- getPkgOpts pkgs+          compiler <- view $ compilerPathsL.to cpCompiler+          return (toFilePath compiler, pkgopts ++ args) +      getRunGhcCmd pkgs args = do+          pkgopts <- getPkgOpts pkgs+          interpret <- view $ compilerPathsL.to cpInterpreter+          return (toFilePath interpret, pkgopts ++ args)+       runWithPath :: Maybe FilePath -> RIO EnvConfig () -> RIO EnvConfig ()       runWithPath path callback = case path of         Nothing                  -> callback@@ -884,8 +789,8 @@         Just p                   -> withUnliftIO $ \ul -> D.withCurrentDirectory p $ unliftIO ul callback  -- | Evaluate some haskell code inline.-evalCmd :: EvalOpts -> GlobalOpts -> IO ()-evalCmd EvalOpts {..} go@GlobalOpts {..} = execCmd execOpts go+evalCmd :: EvalOpts -> RIO Runner ()+evalCmd EvalOpts {..} = execCmd execOpts     where       execOpts =           ExecOpts { eoCmd = ExecGhc@@ -894,10 +799,16 @@                    }  -- | Run GHCi in the context of a project.-ghciCmd :: GhciOpts -> GlobalOpts -> IO ()-ghciCmd ghciOpts go@GlobalOpts{..} =-  withBuildConfigAndLock go $ \lk -> do-    munlockFile lk -- Don't hold the lock while in the GHCI.+ghciCmd :: GhciOpts -> RIO Runner ()+ghciCmd ghciOpts =+  let boptsCLI = defaultBuildOptsCLI+          -- using only additional packages, targets then get overriden in `ghci`+          { boptsCLITargets = map T.pack (ghciAdditionalPackages  ghciOpts)+          , boptsCLIInitialBuildSteps = True+          , boptsCLIFlags = ghciFlags ghciOpts+          , boptsCLIGhcOptions = map T.pack (ghciGhcOptions ghciOpts)+          }+  in withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do     bopts <- view buildOptsL     -- override env so running of tests and benchmarks is disabled     let boptsLocal = bopts@@ -908,105 +819,59 @@           (ghci ghciOpts)  -- | List packages in the project.-idePackagesCmd :: () -> GlobalOpts -> IO ()-idePackagesCmd () go =-    withBuildConfig go IDE.listPackages+idePackagesCmd :: (IDE.OutputStream, IDE.ListPackagesCmd) -> RIO Runner ()+idePackagesCmd = withConfig NoReexec . withBuildConfig . uncurry IDE.listPackages  -- | List targets in the project.-ideTargetsCmd :: () -> GlobalOpts -> IO ()-ideTargetsCmd () go =-    withBuildConfig go IDE.listTargets+ideTargetsCmd :: IDE.OutputStream -> RIO Runner ()+ideTargetsCmd = withConfig NoReexec . withBuildConfig . IDE.listTargets  -- | Pull the current Docker image.-dockerPullCmd :: () -> GlobalOpts -> IO ()-dockerPullCmd _ go@GlobalOpts{..} =-    loadConfigWithOpts go $ \lc ->-    -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?-    withUserFileLock go (view stackRootL lc) $ \_ ->-     runRIO (lcConfig lc) $-       Docker.preventInContainer Docker.pull+dockerPullCmd :: () -> RIO Runner ()+dockerPullCmd () = withConfig NoReexec $ Docker.preventInContainer Docker.pull  -- | Reset the Docker sandbox.-dockerResetCmd :: Bool -> GlobalOpts -> IO ()-dockerResetCmd keepHome go@GlobalOpts{..} =-    loadConfigWithOpts go $ \lc ->-    -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?-    withUserFileLock go (view stackRootL lc) $ \_ ->-      runRIO (lcConfig lc) $-        Docker.preventInContainer $ Docker.reset (lcProjectRoot lc) keepHome---- | Cleanup Docker images and containers.-dockerCleanupCmd :: Docker.CleanupOpts -> GlobalOpts -> IO ()-dockerCleanupCmd cleanupOpts go@GlobalOpts{..} =-    loadConfigWithOpts go $ \lc ->-    -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?-    withUserFileLock go (view stackRootL lc) $ \_ ->-     runRIO (lcConfig lc) $-        Docker.preventInContainer $-            Docker.cleanup cleanupOpts--cfgSetCmd :: ConfigCmd.ConfigCmdSet -> GlobalOpts -> IO ()-cfgSetCmd co go@GlobalOpts{..} =-    withMiniConfigAndLock-        go-        (cfgCmdSet go co)--imgDockerCmd :: (Bool, [Text]) -> GlobalOpts -> IO ()-imgDockerCmd (rebuild,images) go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> do-    let mProjectRoot = lcProjectRoot lc-    withBuildConfigExt-        False-        go-        Nothing-        (\lk ->-              do when rebuild $-                     Stack.Build.build-                         (const (return ()))-                         lk-                         defaultBuildOptsCLI-                 Image.stageContainerImageArtifacts mProjectRoot images)-        (Just $ Image.createContainerImageFromStage mProjectRoot images)+dockerResetCmd :: Bool -> RIO Runner ()+dockerResetCmd = withConfig NoReexec . Docker.preventInContainer . Docker.reset  -- | Project initialization-initCmd :: InitOpts -> GlobalOpts -> IO ()-initCmd initOpts go = do+initCmd :: InitOpts -> RIO Runner ()+initCmd initOpts = do     pwd <- getCurrentDir-    withMiniConfigAndLock go (initProject IsInitCmd pwd initOpts (globalResolver go))+    go <- view globalOptsL+    withGlobalProject $ withConfig YesReexec (initProject pwd initOpts (globalResolver go))  -- | Create a project directory structure and initialize the stack config.-newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO ()-newCmd (newOpts,initOpts) go@GlobalOpts{..} =-    withMiniConfigAndLock go $ do+newCmd :: (NewOpts,InitOpts) -> RIO Runner ()+newCmd (newOpts,initOpts) =+    withGlobalProject $ withConfig YesReexec $ do         dir <- new newOpts (forceOverwrite initOpts)         exists <- doesFileExist $ dir </> stackDotYaml-        when (forceOverwrite initOpts || not exists) $-            initProject IsNewCmd dir initOpts globalResolver---- | List the available templates.-templatesCmd :: () -> GlobalOpts -> IO ()-templatesCmd _ go@GlobalOpts{..} = withConfigAndLock go templatesHelp---- | Fix up extra-deps for a project-solverCmd :: Bool -- ^ modify stack.yaml automatically?-          -> GlobalOpts-          -> IO ()-solverCmd fixStackYaml go =-    withBuildConfigAndLock go (\_ -> solveExtraDeps fixStackYaml)+        when (forceOverwrite initOpts || not exists) $ do+            go <- view globalOptsL+            initProject dir initOpts (globalResolver go) --- | Visualize dependencies-dotCmd :: DotOpts -> GlobalOpts -> IO ()-dotCmd dotOpts go = withBuildConfigDot dotOpts go $ dot dotOpts+-- | Display instructions for how to use templates+templatesCmd :: () -> RIO Runner ()+templatesCmd () = withConfig NoReexec templatesHelp  -- | Query build information-queryCmd :: [String] -> GlobalOpts -> IO ()-queryCmd selectors go = withBuildConfig go $ queryBuildInfo $ map T.pack selectors+queryCmd :: [String] -> RIO Runner ()+queryCmd selectors = withConfig YesReexec $ withDefaultEnvConfig $ queryBuildInfo $ map T.pack selectors  -- | Generate a combined HPC report-hpcReportCmd :: HpcReportOpts -> GlobalOpts -> IO ()-hpcReportCmd hropts go = withBuildConfig go $ generateHpcReportForTargets hropts+hpcReportCmd :: HpcReportOpts -> RIO Runner ()+hpcReportCmd hropts = do+    let (tixFiles, targetNames) = partition (".tix" `T.isSuffixOf`) (hroptsInputs hropts)+        boptsCLI = defaultBuildOptsCLI+          { boptsCLITargets = if hroptsAll hropts then [] else targetNames }+    withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $+        generateHpcReportForTargets hropts tixFiles targetNames +freezeCmd :: FreezeOpts -> RIO Runner ()+freezeCmd freezeOpts = withConfig YesReexec $ withDefaultEnvConfig $ freeze freezeOpts+ data MainException = InvalidReExecVersion String String-                   | UpgradeCabalUnusable                    | InvalidPathForExec FilePath      deriving (Typeable) instance Exception MainException@@ -1018,7 +883,6 @@         , expected         , "; found: "         , actual]-    show UpgradeCabalUnusable = "--upgrade-cabal cannot be used when nix is activated"     show (InvalidPathForExec path) = concat         [ "Got an invalid --cwd argument for stack exec ("         , path
− src/test/Network/HTTP/Download/VerifiedSpec.hs 
@@ -1,132 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Network.HTTP.Download.VerifiedSpec where--import           Control.Retry                  (limitRetries)-import           Crypto.Hash-import           Network.HTTP.StackClient-import           Network.HTTP.Download.Verified-import           Path-import           Path.IO hiding (withSystemTempDir)-import           Stack.Prelude-import           Stack.Types.Runner-import           System.IO (writeFile, readFile)-import           Test.Hspec---- TODO: share across test files-withTempDir' :: (Path Abs Dir -> IO a) -> IO a-withTempDir' = withSystemTempDir "NHD_VerifiedSpec"---- | An example path to download the exampleReq.-getExamplePath :: Path Abs Dir -> IO (Path Abs File)-getExamplePath dir = do-    file <- parseRelFile "cabal-install-1.22.4.0.tar.gz"-    return (dir </> file)---- | An example DownloadRequest that uses a SHA1-exampleReq :: DownloadRequest-exampleReq = fromMaybe (error "exampleReq") $ do-    let req = parseRequest_ "http://download.fpcomplete.com/stackage-cli/linux64/cabal-install-1.22.4.0.tar.gz"-    return DownloadRequest-        { drRequest = req-        , drHashChecks = [exampleHashCheck]-        , drLengthCheck = Just exampleLengthCheck-        , drRetryPolicy = limitRetries 1-        }--exampleHashCheck :: HashCheck-exampleHashCheck = HashCheck-    { hashCheckAlgorithm = SHA1-    , hashCheckHexDigest = CheckHexDigestString "b98eea96d321cdeed83a201c192dac116e786ec2"-    }--exampleLengthCheck :: LengthCheck-exampleLengthCheck = 302513---- | The wrong ContentLength for exampleReq-exampleWrongContentLength :: Int-exampleWrongContentLength = 302512---- | The wrong SHA1 digest for exampleReq-exampleWrongDigest :: CheckHexDigest-exampleWrongDigest = CheckHexDigestString "b98eea96d321cdeed83a201c192dac116e786ec3"--exampleWrongContent :: String-exampleWrongContent = "example wrong content"--isWrongContentLength :: VerifiedDownloadException -> Bool-isWrongContentLength WrongContentLength{} = True-isWrongContentLength _ = False--isWrongDigest :: VerifiedDownloadException -> Bool-isWrongDigest WrongDigest{} = True-isWrongDigest _ = False--spec :: Spec-spec = do-  let exampleProgressHook _ = return ()--  describe "verifiedDownload" $ do-    let run func = withRunner LevelError True True ColorNever Nothing False-                 $ \runner -> runRIO runner func-    -- Preconditions:-    -- * the exampleReq server is running-    -- * the test runner has working internet access to it-    it "downloads the file correctly" $ withTempDir' $ \dir -> do-      examplePath <- getExamplePath dir-      doesFileExist examplePath `shouldReturn` False-      let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook-      go `shouldReturn` True-      doesFileExist examplePath `shouldReturn` True--    it "is idempotent, and doesn't redownload unnecessarily" $ withTempDir' $ \dir -> do-      examplePath <- getExamplePath dir-      doesFileExist examplePath `shouldReturn` False-      let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook-      go `shouldReturn` True-      doesFileExist examplePath `shouldReturn` True-      go `shouldReturn` False-      doesFileExist examplePath `shouldReturn` True--    -- https://github.com/commercialhaskell/stack/issues/372-    it "does redownload when the destination file is wrong" $ withTempDir' $ \dir -> do-      examplePath <- getExamplePath dir-      let exampleFilePath = toFilePath examplePath-      writeFile exampleFilePath exampleWrongContent-      doesFileExist examplePath `shouldReturn` True-      readFile exampleFilePath `shouldReturn` exampleWrongContent-      let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook-      go `shouldReturn` True-      doesFileExist examplePath `shouldReturn` True-      readFile exampleFilePath `shouldNotReturn` exampleWrongContent--    it "rejects incorrect content length" $ withTempDir' $ \dir -> do-      examplePath <- getExamplePath dir-      let wrongContentLengthReq = exampleReq-            { drLengthCheck = Just exampleWrongContentLength-            }-      let go = run $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook-      go `shouldThrow` isWrongContentLength-      doesFileExist examplePath `shouldReturn` False--    it "rejects incorrect digest" $ withTempDir' $ \dir -> do-      examplePath <- getExamplePath dir-      let wrongHashCheck = exampleHashCheck { hashCheckHexDigest = exampleWrongDigest }-      let wrongDigestReq = exampleReq { drHashChecks = [wrongHashCheck] }-      let go = run $ verifiedDownload wrongDigestReq examplePath exampleProgressHook-      go `shouldThrow` isWrongDigest-      doesFileExist examplePath `shouldReturn` False--    -- https://github.com/commercialhaskell/stack/issues/240-    it "can download hackage tarballs" $ withTempDir' $ \dir -> do-      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-            , drHashChecks = []-            , drLengthCheck = Nothing-            , drRetryPolicy = limitRetries 1-            }-      let go = run $ verifiedDownload dReq dest exampleProgressHook-      doesFileExist dest `shouldReturn` False-      go `shouldReturn` True-      doesFileExist dest `shouldReturn` True
src/test/Spec.hs view
@@ -1,2 +1,1 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
src/test/Stack/ArgsSpec.hs view
@@ -8,7 +8,6 @@ import Data.Attoparsec.Interpreter (interpreterArgsParser) import qualified Data.Attoparsec.Text as P import Data.Text (pack)-import Stack.Constants (stackProgName) import Stack.Prelude import Test.Hspec import Prelude (head)@@ -87,8 +86,7 @@                            Left _ -> True                            Right _ -> False -      showInput i = "BEGIN =>" ++ i ++ "<= END"-      testAndCheck checker out inp = it (showInput inp) $ checker out inp+      testAndCheck checker out inp = it (show inp) $ checker out inp        checkLines args = forM_         (interpreterGenValid lineComment args)
src/test/Stack/Build/TargetSpec.hs view
@@ -1,15 +1,13 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-} module Stack.Build.TargetSpec (main, spec) where  import qualified Data.Text           as T+import           Distribution.Types.PackageName (mkPackageName)+import           Distribution.Version (mkVersion) import           Stack.Build.Target import           Stack.Prelude import           Stack.Types.NamedComponent-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Version import           Test.Hspec  main :: IO ()@@ -19,13 +17,13 @@ spec = do     describe "parseRawTarget" $ do         let test s e = it s $ parseRawTarget (T.pack s) `shouldBe` e-        test "foobar" $ Just $ RTPackage $(mkPackageName "foobar")+        test "foobar" $ Just $ RTPackage (mkPackageName "foobar")         test "foobar-1.2.3" $ Just $ RTPackageIdentifier $ PackageIdentifier-            $(mkPackageName "foobar") $(mkVersion "1.2.3")+            (mkPackageName "foobar") (mkVersion [1, 2, 3])         test "./foobar" Nothing         test "foobar/" Nothing         test "/foobar" Nothing         test ":some-exe" $ Just $ RTComponent "some-exe"-        test "foobar:some-exe" $ Just $ RTPackageComponent $(mkPackageName "foobar") $ UnresolvedComponent "some-exe"-        test "foobar:exe:some-exe" $ Just $ RTPackageComponent $(mkPackageName "foobar")+        test "foobar:some-exe" $ Just $ RTPackageComponent (mkPackageName "foobar") $ UnresolvedComponent "some-exe"+        test "foobar:exe:some-exe" $ Just $ RTPackageComponent (mkPackageName "foobar")             $ ResolvedComponent $ CExe "some-exe"
+ src/test/Stack/Config/DockerSpec.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+module Stack.Config.DockerSpec (spec) where++import Test.Hspec+import Test.Hspec.QuickCheck+import Stack.Prelude+import Stack.Types.Resolver+import RIO.Time (fromGregorian)+import Stack.Config.Docker (parseLtsName, addDefaultTag)++spec :: Spec+spec = do+  prop "parseLtsName" $ \(abs -> x) (abs -> y) -> do+    case ltsSnapshotLocation x y of+      RSLUrl url _ ->+        case parseLtsName url of+          Just (x', y') -> do+            x `shouldBe` x'+            y `shouldBe` y'+          Nothing -> error "parseLtsName failed"+      loc -> error $ show loc+  describe "addDefaultTag" $ do+    it "succeeds fails no resolver" $ addDefaultTag "foo/bar" Nothing Nothing `shouldBe` Nothing+    it "succeeds on LTS" $+      addDefaultTag+        "foo/bar"+        Nothing+        (Just $ ARResolver $ ltsSnapshotLocation 1 2)+      `shouldBe` Just "foo/bar:lts-1.2"+    it "fails on nightly" $+      addDefaultTag+        "foo/bar"+        Nothing+        (Just $ ARResolver $ nightlySnapshotLocation $ fromGregorian 2018 1 1)+      `shouldBe` Nothing
src/test/Stack/ConfigSpec.hs view
@@ -1,18 +1,20 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards  #-}-{-# LANGUAGE TemplateHaskell  #-} module Stack.ConfigSpec where  import Control.Arrow-import Data.Aeson.Extended+import Pantry.Internal.AesonExtended import Data.Yaml+import Pantry.Internal (pcHpackExecutable) import Path import Path.IO hiding (withSystemTempDir) import Stack.Config import Stack.Prelude+import Stack.Runners import Stack.Types.Config-import Stack.Types.Runner+import Stack.Options.GlobalParser (globalOptsFromMonoid) import System.Directory import System.Environment import System.IO (writeFile)@@ -56,8 +58,24 @@   "with-hpack: /usr/local/bin/hpack\n" ++   "packages: ['.']\n" +resolverConfig :: String+resolverConfig =+  "resolver: lts-2.10\n" +++  "packages: ['.']\n"++snapshotConfig :: String+snapshotConfig =+  "snapshot: lts-2.10\n" +++  "packages: ['.']\n"++resolverSnapshotConfig :: String+resolverSnapshotConfig =+  "resolver: lts-2.10\n" +++  "snapshot: lts-2.10\n" +++  "packages: ['.']\n"+ stackDotYaml :: Path Rel File-stackDotYaml = $(mkRelFile "stack.yaml")+stackDotYaml = either impureThrow id (parseRelFile "stack.yaml")  setup :: IO () setup = unsetEnv "STACK_YAML"@@ -67,7 +85,7 @@  spec :: Spec spec = beforeAll setup $ do-  let logLevel = LevelDebug+  let logLevel = LevelOther "silent"   -- TODO(danburton): not use inTempDir   let inTempDir action = do         currentDirectory <- getCurrentDirectory@@ -82,11 +100,42 @@         let resetVar = setEnv name originalValue         bracket_ setVar resetVar action +  describe "parseProjectAndConfigMonoid" $ do+    let loadProject' fp inner = do+          globalOpts <- globalOptsFromMonoid False mempty+          withRunnerGlobal globalOpts { globalLogLevel = logLevel } $ do+              iopc <- loadConfigYaml (+                parseProjectAndConfigMonoid (parent fp)+                ) fp+              ProjectAndConfigMonoid project _ <- liftIO iopc+              liftIO $ inner project++        toAbsPath path = do+          parentDir <- getCurrentDirectory >>= parseAbsDir+          return (parentDir </> path)++        loadProject config inner = do+          yamlAbs <- toAbsPath stackDotYaml+          writeFile (toFilePath yamlAbs) config+          loadProject' yamlAbs inner++    it "parses snapshot using 'resolver'" $ inTempDir $ do+      loadProject resolverConfig $ \Project{..} ->+        projectResolver `shouldBe` ltsSnapshotLocation 2 10++    it "parses snapshot using 'snapshot'" $ inTempDir $ do+      loadProject snapshotConfig $ \Project{..} ->+        projectResolver `shouldBe` ltsSnapshotLocation 2 10++    it "throws if both 'resolver' and 'snapshot' are present" $ inTempDir $ do+      loadProject resolverSnapshotConfig (const (return ()))+        `shouldThrow` anyException+   describe "loadConfig" $ do-    let loadConfig' inner =-          withRunner logLevel True False ColorAuto Nothing False $ \runner -> do-            lc <- runRIO runner $ loadConfig mempty Nothing SYLDefault-            inner lc+    let loadConfig' inner = do+          globalOpts <- globalOptsFromMonoid False mempty+          withRunnerGlobal globalOpts { globalLogLevel = logLevel } $+            loadConfig inner     -- TODO(danburton): make sure parent dirs also don't have config file     it "works even if no config file exists" $ example $       loadConfig' $ const $ return ()@@ -96,22 +145,23 @@       -- TODO(danburton): more specific test for exception       loadConfig' (const (return ())) `shouldThrow` anyException +    let configOverrideHpack = pcHpackExecutable . view pantryConfigL+     it "parses config option with-hpack" $ inTempDir $ do       writeFile (toFilePath stackDotYaml) hpackConfig-      loadConfig' $ \lc -> do-        let Config{..} = lcConfig lc-        configOverrideHpack `shouldBe` HpackCommand "/usr/local/bin/hpack"+      loadConfig' $ \config ->+        liftIO $ configOverrideHpack config `shouldBe`+        HpackCommand "/usr/local/bin/hpack"      it "parses config bundled hpack" $ inTempDir $ do       writeFile (toFilePath stackDotYaml) sampleConfig-      loadConfig' $ \lc -> do-        let Config{..} = lcConfig lc-        configOverrideHpack `shouldBe` HpackBundled+      loadConfig' $ \config ->+        liftIO $ configOverrideHpack config `shouldBe` HpackBundled      it "parses build config options" $ inTempDir $ do      writeFile (toFilePath stackDotYaml) buildOptsConfig-     loadConfig' $ \lc -> do-      let BuildOpts{..} = configBuild $ lcConfig lc+     loadConfig' $ \config -> liftIO $ do+      let BuildOpts{..} = configBuild  config       boptsLibProfile `shouldBe` True       boptsExeProfile `shouldBe` True       boptsHaddock `shouldBe` True@@ -119,13 +169,14 @@       boptsInstallExes `shouldBe` True       boptsPreFetch `shouldBe` True       boptsKeepGoing `shouldBe` Just True-      boptsKeepTmpFiles `shouldBe` Just True+      boptsKeepTmpFiles `shouldBe` True       boptsForceDirty `shouldBe` True       boptsTests `shouldBe` True       boptsTestOpts `shouldBe` TestOpts {toRerunTests = True                                          ,toAdditionalArgs = ["-fprof"]                                          ,toCoverage = True-                                         ,toDisableRun = True}+                                         ,toDisableRun = True+                                         ,toMaximumTimeSeconds = Nothing}       boptsBenchmarks `shouldBe` True       boptsBenchmarkOpts `shouldBe` BenchmarkOpts {beoAdditionalArgs = Just "-O2"                                                    ,beoDisableRun = True}@@ -133,33 +184,37 @@       boptsCabalVerbose `shouldBe` True      it "finds the config file in a parent directory" $ inTempDir $ do+      writeFile "package.yaml" "name: foo"       writeFile (toFilePath stackDotYaml) sampleConfig       parentDir <- getCurrentDirectory >>= parseAbsDir       let childDir = "child"       createDirectory childDir       setCurrentDirectory childDir-      loadConfig' $ \LoadConfig{..} -> do-        bc <- liftIO (lcLoadBuildConfig Nothing)+      loadConfig' $ \config -> liftIO $ do+        bc <- runRIO config loadBuildConfig         view projectRootL bc `shouldBe` parentDir      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 $ loadConfig' $ \LoadConfig{..} -> do-          BuildConfig{..} <- lcLoadBuildConfig Nothing+        writeFile (toFilePath dir ++ "/package.yaml") "name: foo"+        withEnvVar "STACK_YAML" stackYamlFp $ loadConfig' $ \config -> liftIO $ do+          BuildConfig{..} <- runRIO config loadBuildConfig           bcStackYaml `shouldBe` dir </> stackDotYaml           parent bcStackYaml `shouldBe` dir      it "STACK_YAML can be relative" $ inTempDir $ do         parentDir <- getCurrentDirectory >>= parseAbsDir-        let childRel = $(mkRelDir "child")-            yamlRel = childRel </> $(mkRelFile "some-other-name.config")+        let childRel = either impureThrow id (parseRelDir "child")+            yamlRel = childRel </> either impureThrow id (parseRelFile "some-other-name.config")             yamlAbs = parentDir </> yamlRel+            packageYaml = childRel </> either impureThrow id (parseRelFile "package.yaml")         createDirectoryIfMissing True $ toFilePath $ parent yamlAbs         writeFile (toFilePath yamlAbs) "resolver: ghc-7.8"-        withEnvVar "STACK_YAML" (toFilePath yamlRel) $ loadConfig' $ \LoadConfig{..} -> do-            BuildConfig{..} <- lcLoadBuildConfig Nothing+        writeFile (toFilePath packageYaml) "name: foo"+        withEnvVar "STACK_YAML" (toFilePath yamlRel) $ loadConfig' $ \config -> liftIO $ do+            BuildConfig{..} <- runRIO config loadBuildConfig             bcStackYaml `shouldBe` yamlAbs    describe "defaultConfigYaml" $
src/test/Stack/DotSpec.hs view
@@ -10,9 +10,8 @@ import qualified Data.Map as Map import qualified Data.Set as Set import           Distribution.License (License (BSD3))-import           Stack.Prelude-import           Stack.Types.PackageName-import           Stack.Types.Version+import qualified RIO.Text as T+import           Stack.Prelude hiding (pkgName) import           Test.Hspec import           Test.Hspec.QuickCheck (prop) import           Test.QuickCheck (forAll,choose,Gen)@@ -20,7 +19,7 @@ import           Stack.Dot  dummyPayload :: DotPayload-dummyPayload = DotPayload (parseVersionFromString "0.0.0.0") (Just (Right BSD3))+dummyPayload = DotPayload (parseVersion "0.0.0.0") (Just (Right BSD3))  spec :: Spec spec = do@@ -54,14 +53,14 @@      prop "requested packages are pruned" $ do       let resolvedGraph = runIdentity (resolveDependencies Nothing graph stubLoader)-          allPackages g = Set.map show (Map.keysSet g `Set.union`  fold (fmap fst g))+          allPackages g = Map.keysSet g `Set.union`  fold (fmap fst g)       forAll (sublistOf (Set.toList (allPackages resolvedGraph))) $ \toPrune ->         let pruned = pruneGraph [pkgName "one", pkgName "two"] toPrune resolvedGraph         in Set.null (allPackages pruned `Set.intersection` Set.fromList toPrune)      prop "pruning removes orhpans" $ do       let resolvedGraph = runIdentity (resolveDependencies Nothing graph stubLoader)-          allPackages g = Set.map show (Map.keysSet g `Set.union` fold (fmap fst g))+          allPackages g = Map.keysSet g `Set.union` fold (fmap fst g)           orphans g = Map.filterWithKey (\k _ -> not (graphElem k g)) g       forAll (sublistOf (Set.toList (allPackages resolvedGraph))) $ \toPrune ->         let pruned = pruneGraph [pkgName "one", pkgName "two"] toPrune resolvedGraph@@ -74,7 +73,7 @@  -- Unsafe internal helper to create a package name pkgName :: Text -> PackageName-pkgName = fromMaybe failure . parsePackageName+pkgName = fromMaybe failure . parsePackageName . T.unpack   where    failure = error "Internal error during package name creation in DotSpec.pkgName"
src/test/Stack/GhciSpec.hs view
@@ -46,11 +46,11 @@  baseProjDir, projDirA, projDirB :: Path Abs Dir baseProjDir = $(mkAbsDir $ defaultDrive FP.</> "Users" FP.</> "someone" FP.</> "src")-projDirA = baseProjDir </> $(mkRelDir "project-a")-projDirB = baseProjDir </> $(mkRelDir "project-b")+projDirA = baseProjDir </> either impureThrow id (parseRelDir "project-a")+projDirB = baseProjDir </> either impureThrow id (parseRelDir "project-b")  relFile :: Path Rel File-relFile = $(mkRelFile $ "exe" FP.</> "Main.hs")+relFile = either impureThrow id (parseRelFile $ "exe" FP.</> "Main.hs")  absFile :: Path Abs File absFile = projDirA </> relFile
+ src/test/Stack/LockSpec.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++module Stack.LockSpec where++import Pantry.Internal.AesonExtended (WithJSONWarnings(..))+import Data.ByteString (ByteString)+import qualified Data.Yaml as Yaml+import Distribution.Types.PackageName (mkPackageName)+import Distribution.Types.Version (mkVersion)+import Pantry+import qualified Pantry.SHA256 as SHA256+import RIO+import Stack.Lock+import Test.Hspec+import Text.RawString.QQ++toBlobKey :: ByteString -> Word -> BlobKey+toBlobKey string size = BlobKey (decodeSHA string) (FileSize size)++decodeSHA :: ByteString -> SHA256+decodeSHA string =+    case SHA256.fromHexBytes string of+        Right csha -> csha+        Left err -> error $ "Failed decoding. Error:  " <> show err++decodeLocked :: ByteString -> IO Locked+decodeLocked bs = do+  val <- Yaml.decodeThrow  bs+  case Yaml.parseEither Yaml.parseJSON val of+    Left err -> throwIO $ Yaml.AesonException err+    Right (WithJSONWarnings res warnings) -> do+      unless (null warnings) $+        throwIO $ Yaml.AesonException $ "Unexpected warnings: " ++ show warnings+      -- we just assume no file references+      resolvePaths Nothing res++spec :: Spec+spec = do+    it "parses lock file (empty with GHC resolver)" $ do+        let lockFile :: ByteString+            lockFile =+                [r|#some+snapshots:+- completed:+    compiler: ghc-8.2.2+  original:+    compiler: ghc-8.2.2+packages: []+|]+        pkgImm <- lckPkgImmutableLocations <$> decodeLocked lockFile+        pkgImm `shouldBe` []+    it "parses lock file (empty with LTS resolver)" $ do+        let lockFile :: ByteString+            lockFile =+                [r|#some+snapshots:+- completed:+    size: 527801+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml+    sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a+  original: lts-11.22+- completed:+    compiler: ghc-8.2.2+  original:+    compiler: ghc-8.2.2+packages: []+|]+        pkgImm <- lckPkgImmutableLocations <$> decodeLocked lockFile+        pkgImm `shouldBe` []+    it "parses lock file (LTS, wai + warp)" $ do+        let lockFile :: ByteString+            lockFile =+                [r|#some+snapshots:+- completed:+    size: 527801+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml+    sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a+  original: lts-11.22+- completed:+    compiler: ghc-8.2.2+  original:+    compiler: ghc-8.2.2+packages:+- original:+    subdir: wai+    git: https://github.com/yesodweb/wai.git+    commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0+  completed:+    subdir: wai+    cabal-file:+      size: 1765+      sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410+    name: wai+    version: 3.2.1.2+    git: https://github.com/yesodweb/wai.git+    pantry-tree:+      size: 714+      sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2+    commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0+- original:+    subdir: warp+    git: https://github.com/yesodweb/wai.git+    commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0+  completed:+    subdir: warp+    cabal-file:+      size: 10725+      sha256: cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758+    name: warp+    version: 3.2.25+    git: https://github.com/yesodweb/wai.git+    pantry-tree:+      size: 5103+      sha256: f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a+    commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0+|]+        pkgImm <- lckPkgImmutableLocations <$> decodeLocked lockFile+        let waiSubdirRepo subdir =+              Repo { repoType = RepoGit+                   , repoUrl = "https://github.com/yesodweb/wai.git"+                   , repoCommit =+                       "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0"+                   , repoSubdir = subdir+                   }+            emptyRPM = RawPackageMetadata { rpmName = Nothing+                                          , rpmVersion = Nothing+                                          , rpmTreeKey = Nothing+                                          , rpmCabal = Nothing+                                          }+        pkgImm `shouldBe`+            [ LockedLocation+              (RPLIRepo (waiSubdirRepo "wai") emptyRPM)+              (PLIRepo (waiSubdirRepo "wai")+                    (PackageMetadata { pmIdent =+                                         PackageIdentifier+                                         { pkgName = mkPackageName "wai"+                                         , pkgVersion = mkVersion [3, 2, 1, 2]+                                         }+                                     , pmTreeKey =+                                         TreeKey+                                         (BlobKey+                                           (decodeSHA+                                             "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2")+                                           (FileSize 714))+                                     , pmCabal =+                                         toBlobKey+                                         "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410"+                                         1765+                                     }))+            , LockedLocation+              (RPLIRepo (waiSubdirRepo "warp") emptyRPM)+              (PLIRepo (waiSubdirRepo "warp")+                   (PackageMetadata { pmIdent =+                                      PackageIdentifier+                                      { pkgName = mkPackageName "warp"+                                      , pkgVersion = mkVersion [3, 2, 25]+                                      }+                                    , pmTreeKey =+                                      TreeKey+                                      (BlobKey+                                        (decodeSHA+                                          "f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a")+                                        (FileSize 5103))+                                    , pmCabal =+                                      toBlobKey+                                      "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758"+                                      10725+                                    }))+            ]
src/test/Stack/NixSpec.hs view
@@ -10,13 +10,12 @@ import Stack.Config import Stack.Config.Nix import Stack.Constants+import Stack.Options.GlobalParser (globalOptsFromMonoid) import Stack.Options.NixParser import Stack.Prelude-import Stack.Types.Compiler+import Stack.Runners import Stack.Types.Config import Stack.Types.Nix-import Stack.Types.Runner-import Stack.Types.Version import System.Directory import System.Environment import Test.Hspec@@ -42,9 +41,11 @@  spec :: Spec spec = beforeAll setup $ do-  let loadConfig' cmdLineArgs =-        withRunner LevelDebug True False ColorAuto Nothing False $ \runner ->-        runRIO runner $ loadConfig cmdLineArgs Nothing SYLDefault+  let loadConfig' :: ConfigMonoid -> (Config -> IO ()) -> IO ()+      loadConfig' cmdLineArgs inner = do+        globalOpts <- globalOptsFromMonoid False mempty { globalMonoidConfigMonoid = cmdLineArgs }+        withRunnerGlobal globalOpts { globalLogLevel = LevelOther "silent" } $+          loadConfig (liftIO . inner)       inTempDir test = do         currentDirectory <- getCurrentDirectory         withSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do@@ -62,45 +63,43 @@   let trueOnNonWindows = not osIsWindows   describe "nix disabled in config file" $     around_ (withStackDotYaml sampleConfigNixDisabled) $ do-      it "sees that the nix shell is not enabled" $ do-        lc <- loadConfig' mempty-        nixEnable (configNix $ lcConfig lc) `shouldBe` False+      it "sees that the nix shell is not enabled" $ loadConfig' mempty $ \config ->+        nixEnable (configNix config) `shouldBe` False       describe "--nix given on command line" $-        it "sees that the nix shell is enabled" $ do-          lc <- loadConfig' (parseOpts ["--nix"])-          nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows+        it "sees that the nix shell is enabled" $+          loadConfig' (parseOpts ["--nix"]) $ \config ->+          nixEnable (configNix config) `shouldBe` trueOnNonWindows       describe "--nix-pure given on command line" $-        it "sees that the nix shell is enabled" $ do-          lc <- loadConfig' (parseOpts ["--nix-pure"])-          nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows+        it "sees that the nix shell is enabled" $+          loadConfig' (parseOpts ["--nix-pure"]) $ \config ->+          nixEnable (configNix config) `shouldBe` trueOnNonWindows       describe "--no-nix given on command line" $-        it "sees that the nix shell is not enabled" $ do-          lc <- loadConfig' (parseOpts ["--no-nix"])-          nixEnable (configNix $ lcConfig lc) `shouldBe` False+        it "sees that the nix shell is not enabled" $+          loadConfig' (parseOpts ["--no-nix"]) $ \config ->+          nixEnable (configNix config) `shouldBe` False       describe "--no-nix-pure given on command line" $-        it "sees that the nix shell is not enabled" $ do-          lc <- loadConfig' (parseOpts ["--no-nix-pure"])-          nixEnable (configNix $ lcConfig lc) `shouldBe` False+        it "sees that the nix shell is not enabled" $+          loadConfig' (parseOpts ["--no-nix-pure"]) $ \config ->+          nixEnable (configNix config) `shouldBe` False   describe "nix enabled in config file" $     around_ (withStackDotYaml sampleConfigNixEnabled) $ do-      it "sees that the nix shell is enabled" $ do-        lc <- loadConfig' mempty-        nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows+      it "sees that the nix shell is enabled" $+        loadConfig' mempty $ \config ->+        nixEnable (configNix config) `shouldBe` trueOnNonWindows       describe "--no-nix given on command line" $-        it "sees that the nix shell is not enabled" $ do-          lc <- loadConfig' (parseOpts ["--no-nix"])-          nixEnable (configNix $ lcConfig lc) `shouldBe` False+        it "sees that the nix shell is not enabled" $+          loadConfig' (parseOpts ["--no-nix"]) $ \config ->+          nixEnable (configNix config) `shouldBe` False       describe "--nix-pure given on command line" $-        it "sees that the nix shell is enabled" $ do-          lc <- loadConfig' (parseOpts ["--nix-pure"])-          nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows+        it "sees that the nix shell is enabled" $+          loadConfig' (parseOpts ["--nix-pure"]) $ \config ->+          nixEnable (configNix config) `shouldBe` trueOnNonWindows       describe "--no-nix-pure given on command line" $-        it "sees that the nix shell is enabled" $ do-          lc <- loadConfig' (parseOpts ["--no-nix-pure"])-          nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows-      it "sees that the only package asked for is glpk and asks for the correct GHC derivation" $ do-        lc <- loadConfig' mempty-        nixPackages (configNix $ lcConfig lc) `shouldBe` ["glpk"]-        v <- parseVersion "7.10.3"-        ghc <- either throwIO return $ nixCompiler (GhcVersion v)+        it "sees that the nix shell is enabled" $+          loadConfig' (parseOpts ["--no-nix-pure"]) $ \config ->+          nixEnable (configNix config) `shouldBe` trueOnNonWindows+      it "sees that the only package asked for is glpk and asks for the correct GHC derivation" $ loadConfig' mempty $ \config -> do+        nixPackages (configNix config) `shouldBe` ["glpk"]+        v <- parseVersionThrowing "7.10.3"+        ghc <- either throwIO return $ nixCompiler (WCGhc v)         ghc `shouldBe` "haskell.compiler.ghc7103"
src/test/Stack/PackageDumpSpec.hs view
@@ -1,22 +1,21 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-} {-# LANGUAGE TupleSections     #-} module Stack.PackageDumpSpec where -import           Data.Conduit+import           Conduit import qualified Data.Conduit.List             as CL import           Data.Conduit.Text             (decodeUtf8) import qualified Data.Map                      as Map import qualified Data.Set                      as Set import           Distribution.License          (License(..))+import           Distribution.Types.PackageName (mkPackageName)+import           Distribution.Version          (mkVersion)+import           Path                          (parseAbsFile) import           Stack.PackageDump import           Stack.Prelude-import           Stack.Types.Compiler+import           Stack.Types.Config import           Stack.Types.GhcPkgId-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Version import           RIO.Process import           Test.Hspec import           Test.Hspec.QuickCheck@@ -72,13 +71,14 @@                .| conduitDumpPackage                .| CL.consume             ghcPkgId <- parseGhcPkgId "haskell2010-1.1.2.0-05c8dd51009e08c6371c82972d40f55a"-            packageIdent <- parsePackageIdentifier "haskell2010-1.1.2.0"+            packageIdent <- maybe (fail "Not parsable package id") return $+              parsePackageIdentifier "haskell2010-1.1.2.0"             depends <- mapM parseGhcPkgId                 [ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b"                 , "base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1"                 , "ghc-prim-0.3.1.0-a24f9c14c632d75b683d0f93283aea37"                 ]-            haskell2010 { dpExposedModules = [] } `shouldBe` DumpPackage+            haskell2010 { dpExposedModules = mempty } `shouldBe` DumpPackage                 { dpGhcPkgId = ghcPkgId                 , dpPackageIdent = packageIdent                 , dpParentLibIdent = Nothing@@ -89,11 +89,8 @@                 , dpHasExposedModules = True                 , dpHaddockInterfaces = ["/opt/ghc/7.8.4/share/doc/ghc/html/libraries/haskell2010-1.1.2.0/haskell2010.haddock"]                 , dpHaddockHtml = Just "/opt/ghc/7.8.4/share/doc/ghc/html/libraries/haskell2010-1.1.2.0"-                , dpProfiling = ()-                , dpHaddock = ()-                , dpSymbols = ()                 , dpIsExposed = False-                , dpExposedModules = []+                , dpExposedModules = mempty                 }          it "ghc 7.10" $ do@@ -105,7 +102,8 @@                .| conduitDumpPackage                .| CL.consume             ghcPkgId <- parseGhcPkgId "ghc-7.10.1-325809317787a897b7a97d646ceaa3a3"-            pkgIdent <- parsePackageIdentifier "ghc-7.10.1"+            pkgIdent <- maybe (fail "Not parsable package id") return $+              parsePackageIdentifier "ghc-7.10.1"             depends <- mapM parseGhcPkgId                 [ "array-0.5.1.0-e29cdbe82692341ebb7ce6e2798294f9"                 , "base-4.8.0.0-1b689eb8d72c4d4cc88f445839c1f01a"@@ -122,7 +120,7 @@                 , "transformers-0.4.2.0-c1a7bb855a176fe475d7b665301cd48f"                 , "unix-2.7.1.0-e5915eb989e568b732bc7286b0d0817f"                 ]-            haskell2010 { dpExposedModules = [] } `shouldBe` DumpPackage+            haskell2010 { dpExposedModules = mempty } `shouldBe` DumpPackage                 { dpGhcPkgId = ghcPkgId                 , dpPackageIdent = pkgIdent                 , dpParentLibIdent = Nothing@@ -133,11 +131,8 @@                 , dpDepends = depends                 , dpLibraries = ["HSghc-7.10.1-EMlWrQ42XY0BNVbSrKixqY"]                 , dpHasExposedModules = True-                , dpProfiling = ()-                , dpHaddock = ()-                , dpSymbols = ()                 , dpIsExposed = False-                , dpExposedModules = []+                , dpExposedModules = mempty                 }         it "ghc 7.8.4 (osx)" $ do             hmatrix:_ <-@@ -148,7 +143,8 @@                .| conduitDumpPackage                .| CL.consume             ghcPkgId <- parseGhcPkgId "hmatrix-0.16.1.5-12d5d21f26aa98774cdd8edbc343fbfe"-            pkgId <- parsePackageIdentifier "hmatrix-0.16.1.5"+            pkgId <- maybe (fail "Not parsable package id") return $+              parsePackageIdentifier "hmatrix-0.16.1.5"             depends <- mapM parseGhcPkgId                 [ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b"                 , "base-4.7.0.2-918c7ac27f65a87103264a9f51652d63"@@ -174,11 +170,8 @@                 , dpDepends = depends                 , dpLibraries = ["HShmatrix-0.16.1.5"]                 , dpHasExposedModules = True-                , dpProfiling = ()-                , dpHaddock = ()-                , dpSymbols = ()                 , dpIsExposed = True-                , dpExposedModules = ["Data.Packed","Data.Packed.Vector","Data.Packed.Matrix","Data.Packed.Foreign","Data.Packed.ST","Data.Packed.Development","Numeric.LinearAlgebra","Numeric.LinearAlgebra.LAPACK","Numeric.LinearAlgebra.Algorithms","Numeric.Container","Numeric.LinearAlgebra.Util","Numeric.LinearAlgebra.Devel","Numeric.LinearAlgebra.Data","Numeric.LinearAlgebra.HMatrix","Numeric.LinearAlgebra.Static"]+                , dpExposedModules = Set.fromList ["Data.Packed","Data.Packed.Vector","Data.Packed.Matrix","Data.Packed.Foreign","Data.Packed.ST","Data.Packed.Development","Numeric.LinearAlgebra","Numeric.LinearAlgebra.LAPACK","Numeric.LinearAlgebra.Algorithms","Numeric.Container","Numeric.LinearAlgebra.Util","Numeric.LinearAlgebra.Devel","Numeric.LinearAlgebra.Data","Numeric.LinearAlgebra.HMatrix","Numeric.LinearAlgebra.Static"]                 }         it "ghc HEAD" $ do           ghcBoot:_ <-@@ -189,7 +182,8 @@              .| conduitDumpPackage              .| CL.consume           ghcPkgId <- parseGhcPkgId "ghc-boot-0.0.0.0"-          pkgId <- parsePackageIdentifier "ghc-boot-0.0.0.0"+          pkgId <- maybe (fail "Not parsable package id") return $+            parsePackageIdentifier "ghc-boot-0.0.0.0"           depends <- mapM parseGhcPkgId             [ "base-4.9.0.0"             , "binary-0.7.5.0"@@ -209,37 +203,21 @@             , dpDepends = depends             , dpLibraries = ["HSghc-boot-0.0.0.0"]             , dpHasExposedModules = True-            , dpProfiling = ()-            , dpHaddock = ()-            , dpSymbols = ()             , dpIsExposed = True-            , dpExposedModules = ["GHC.Lexeme", "GHC.PackageDb"]+            , dpExposedModules = Set.fromList ["GHC.Lexeme", "GHC.PackageDb"]             }  -    it "ghcPkgDump + addProfiling + addHaddock" $ runEnvNoLogging $ do-        icache <- newInstalledCache-        ghcPkgDump Ghc []-            $  conduitDumpPackage-            .| addProfiling icache-            .| addHaddock icache-            .| fakeAddSymbols-            .| CL.sinkNull--    it "sinkMatching" $ runEnvNoLogging $ do-        icache <- newInstalledCache-        m <- ghcPkgDump Ghc []+    it "sinkMatching" $ runEnvNoLogging $ \pkgexe -> do+        m <- ghcPkgDump pkgexe []             $  conduitDumpPackage-            .| addProfiling icache-            .| addHaddock icache-            .| fakeAddSymbols-            .| sinkMatching False False False (Map.singleton $(mkPackageName "transformers") $(mkVersion "0.0.0.0.0.0.1"))-        case Map.lookup $(mkPackageName "base") m of+            .| sinkMatching (Map.singleton (mkPackageName "transformers") (mkVersion [0, 0, 0, 0, 0, 0, 1]))+        case Map.lookup (mkPackageName "base") m of             Nothing -> error "base not present"             Just _ -> return ()         liftIO $ do-          Map.lookup $(mkPackageName "transformers") m `shouldBe` Nothing-          Map.lookup $(mkPackageName "ghc") m `shouldBe` Nothing+          Map.lookup (mkPackageName "transformers") m `shouldBe` Nothing+          Map.lookup (mkPackageName "ghc") m `shouldBe` Nothing      describe "pruneDeps" $ do         it "sanity check" $ do@@ -282,12 +260,10 @@             Nothing -> error "checkDepsPresent: missing in depMap"             Just deps -> Set.null $ Set.difference (Set.fromList deps) allIds --- addSymbols can't be reasonably tested like this-fakeAddSymbols :: Monad m => ConduitM (DumpPackage a b c) (DumpPackage a b Bool) m ()-fakeAddSymbols = CL.map (\dp -> dp { dpSymbols = False })--runEnvNoLogging :: RIO LoggedProcessContext a -> IO a+runEnvNoLogging :: (GhcPkgExe -> RIO LoggedProcessContext a) -> IO a runEnvNoLogging inner = do   envVars <- view envVarsL <$> mkDefaultProcessContext   menv <- mkProcessContext $ Map.delete "GHC_PACKAGE_PATH" envVars-  runRIO (LoggedProcessContext menv mempty) inner+  let find name = runRIO menv (findExecutable name) >>= either throwIO parseAbsFile+  pkg <- GhcPkgExe <$> find "ghc-pkg"+  runRIO (LoggedProcessContext menv mempty) (inner pkg)
− src/test/Stack/SolverSpec.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}--- | Test suite for "Stack.Solver"-module Stack.SolverSpec where--import           Data.Text (unpack)-import           Stack.Prelude-import           Stack.Types.FlagName-import           Stack.Types.PackageName-import           Stack.Types.Version-import           Test.Hspec-import qualified Data.Map as Map--import Stack.Solver--spec :: Spec-spec =-  describe "Stack.Solver" $ do-    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-      "hspec-snap-1.0.0.0 *test (via: servant-snap-0.5) (new package)"-      $(mkPackageName "hspec-snap")-      $(mkVersion "1.0.0.0")-      []-    successfulExample-      "time-locale-compat-0.1.1.1 -old-locale (via: http-api-data-0.2.2) (new package)"-      $(mkPackageName "time-locale-compat")-      $(mkVersion "0.1.1.1")-      [ ($(mkFlagName "old-locale"), False)-      ]-    successfulExample-      "flowdock-rest-0.2.0.0 -aeson-compat *test (via: haxl-fxtra-0.0.0.0) (new package)"-      $(mkPackageName "flowdock-rest")-      $(mkVersion "0.2.0.0")-      [ ($(mkFlagName "aeson-compat"), False)-      ]-  where-    successfulExample input pkgName pkgVersion flags =-      it ("parses " ++ unpack input) $-        parseCabalOutputLine input `shouldBe` Right (pkgName, (pkgVersion, Map.fromList flags))
− src/test/Stack/StaticBytesSpec.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoImplicitPrelude #-}-module Stack.StaticBytesSpec (spec) where--import Stack.StaticBytes-import Stack.Prelude-import qualified Data.ByteString as B-import qualified Data.Vector.Unboxed as VU-import qualified Data.Vector.Primitive as VP-import qualified Data.Vector.Storable as VS-import Test.Hspec-import Test.Hspec.QuickCheck-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE--spec :: Spec-spec = do-  describe "ByteString" $ tests B.pack-  describe "Storable Vector" $ tests VS.fromList-  describe "Unboxed Vector" $ tests VU.fromList-  describe "Primitive Vector" $ tests VP.fromList--tests :: (Eq dbytes, Show dbytes, DynamicBytes dbytes) => ([Word8] -> dbytes) -> Spec-tests pack = do-  it "disallows 4 bytes" $ do-    toStaticExact (pack [1..4]) `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes8)-  it "toStaticExact matches ByteString" $ do-    let octets = [1..8]-        (expected :: Bytes8) = either impureThrow id $ toStaticExact (B.pack octets)-        actual = either impureThrow id $ toStaticExact (pack octets)-    actual `shouldBe` expected--  it "fromStatic round trips" $ do-    let octets = [1..8]-        v1 = pack octets-        (b8 :: Bytes8) = either impureThrow id $ toStaticExact v1-        v2 = fromStatic b8-    v2 `shouldBe` v1--  it "allows 8 bytes" $ do-    let bs = pack [1..8]-    case toStaticExact bs of-      Left e -> throwIO e-      Right b8 -> fromStatic (b8 :: Bytes8) `shouldBe` bs-    toStaticExact bs `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes16)-  it "padding is the same as trailing nulls" $ do-    let bs1 = pack $ [1..4] ++ replicate 4 0-        bs2 = pack [1..4]-    Right (toStaticPadTruncate bs2 :: Bytes8) `shouldBe` toStaticExact bs1--  prop "handles bytes16" $ \octets -> do-    let bs = pack $ take 16 octets-        (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs-    fromStatic b16 `shouldBe` pack (take 16 (octets ++ replicate 16 0))--  it "spot check bytes16" $ do-    let bs = pack $ replicate 16 0-        (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs-    fromStatic b16 `shouldBe` pack (replicate 16 0)--  prop "handles bytes32" $ \octets -> do-    let bs = pack $ take 32 octets-        (b32 :: Bytes32) = either impureThrow id $ toStaticPad bs-    fromStatic b32 `shouldBe` pack (take 32 (take 32 octets ++ replicate 32 0))--  prop "fuzz with encodeUtf8" $ \chars -> do-    let t = T.pack $ filter (/= '\0') chars-        bs = TE.encodeUtf8 t-        bs128 = pack $ B.unpack $ B.take 128 $ bs `B.append` B.replicate 128 0-        b128 = toStaticPadTruncate (pack $ B.unpack bs) :: Bytes128--    fromStatic b128 `shouldBe` bs128
− src/test/Stack/StoreSpec.hs 
@@ -1,84 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -fno-warn-orphans -Wwarn #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-module Stack.StoreSpec where--import qualified Data.ByteString as BS-import           Data.Containers (mapFromList, setFromList)-import           Data.Sequences (fromList)-import           Data.Store.Internal (StaticSize (..))-import           Data.Store.TH-import qualified Data.Vector.Unboxed as UV-import           GHC.TypeLits (KnownNat)-import           Language.Haskell.TH-import           Language.Haskell.TH.ReifyMany-import           Stack.Prelude-import           Stack.Types.Build-import           Stack.Types.PackageDump-import           Test.Hspec-import           Test.SmallCheck.Series---- NOTE: these were copied from Data.Store. Should probably be moved to--- smallcheck.--instance (Monad m, Serial m k, Serial m a, Ord k) => Serial m (Map k a) where-    series = fmap mapFromList series--instance (Monad m, Serial m k, Serial m a, Eq k, Hashable k) => Serial m (HashMap k a) where-    series = fmap mapFromList series--instance Monad m => Serial m Text where-    series = fmap fromList series--instance (Monad m, Serial m a, UV.Unbox a) => Serial m (UV.Vector a) where-    series = fmap fromList series--instance Monad m => Serial m BS.ByteString where-    series = fmap BS.pack series--instance (Monad m, Serial m a, Ord a) => Serial m (Set a) where-    series = fmap setFromList series--instance (Monad m, KnownNat n) => Serial m (StaticSize n BS.ByteString)--addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a]-addMinAndMaxBounds xs =-    (if (minBound :: a) `notElem` xs then [minBound] else []) ++-    (if (maxBound :: a) `notElem` xs && (maxBound :: a) /= minBound then maxBound : xs else xs)--$(do let tys = [ ''InstalledCacheInner-               -- FIXME , ''PackageCache-               -- FIXME , ''LoadedSnapshot-               , ''BuildCache-               , ''ConfigCache-               ]-     ns <- reifyManyWithoutInstances ''Serial tys (`notElem` [''UV.Vector])-     let f n = [d| instance Monad m => Serial m $(conT n) |]-     concat <$> mapM f ns)--verbose :: Bool-verbose = False--spec :: Spec-spec = do-    describe "Roundtrips binary formats" $ do-        $(smallcheckManyStore False 6-            [ [t| InstalledCacheInner |]-            , [t| BuildCache |]-            ])-        -- Blows up with > 5-        {--        $(smallcheckManyStore False 5-            [ -- FIXME [t| PackageCache |]-            -- FIXME , [t| LoadedSnapshot |]-            ])-        -}-        -- Blows up with > 4-        $(smallcheckManyStore False 4-            [ [t| ConfigCache |]-            ])
− src/test/Stack/Types/BuildPlanSpec.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Stack.Types.BuildPlanSpec where--import           Data.Aeson.Extended (WithJSONWarnings(..))-import           Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8-import           Data.Yaml (decodeThrow)-import           Stack.Types.BuildPlan-import           Test.Hspec--spec :: Spec-spec =-  describe "PackageLocation" $ do-    describe "Archive" $ do-      describe "github" $ do-        let decode' :: ByteString -> Maybe (WithJSONWarnings (PackageLocation Subdirs))-            decode' = decodeThrow--        it "'github' and 'commit' keys" $ do-          let contents :: ByteString-              contents =-                S8.pack-                  (unlines-                    [ "github: oink/town"-                    , "commit: abc123"-                    ])-          let expected :: PackageLocation Subdirs-              expected =-                PLArchive Archive-                  { archiveUrl = "https://github.com/oink/town/archive/abc123.tar.gz"-                  , archiveSubdirs = DefaultSubdirs-                  , archiveHash = Nothing-                  }-          decode' contents `shouldBe` Just (WithJSONWarnings expected [])--        it "'github', 'commit', and 'subdirs' keys" $ do-          let contents :: ByteString-              contents =-                S8.pack-                  (unlines-                    [ "github: oink/town"-                    , "commit: abc123"-                    , "subdirs:"-                    , "  - foo"-                    ])-          let expected :: PackageLocation Subdirs-              expected =-                PLArchive Archive-                  { archiveUrl = "https://github.com/oink/town/archive/abc123.tar.gz"-                  , archiveSubdirs = ExplicitSubdirs ["foo"]-                  , archiveHash = Nothing-                  }-          decode' contents `shouldBe` Just (WithJSONWarnings expected [])--        it "does not parse GitHub repo with no slash" $ do-          let contents :: ByteString-              contents =-                S8.pack-                  (unlines-                    [ "github: oink"-                    , "commit: abc123"-                    ])-          decode' contents `shouldBe` Nothing--        it "does not parse GitHub repo with leading slash" $ do-          let contents :: ByteString-              contents =-                S8.pack-                  (unlines-                    [ "github: /oink"-                    , "commit: abc123"-                    ])-          decode' contents `shouldBe` Nothing--        it "does not parse GitHub repo with trailing slash" $ do-          let contents :: ByteString-              contents =-                S8.pack-                  (unlines-                    [ "github: oink/"-                    , "commit: abc123"-                    ])-          decode' contents `shouldBe` Nothing--        it "does not parse GitHub repo with more than one slash" $ do-          let contents :: ByteString-              contents =-                S8.pack-                  (unlines-                    [ "github: oink/town/here"-                    , "commit: abc123"-                    ])-          decode' contents `shouldBe` Nothing
src/test/Stack/Types/TemplateNameSpec.hs view
@@ -14,26 +14,26 @@       let pathOf s = either error templatePath (parseTemplateNameFromString s)        it "parses out the TemplatePath" $ do-        pathOf "github:user/name"     `shouldBe` (RepoPath $ RepoTemplatePath Github    "user" "name.hsfiles")-        pathOf "bitbucket:user/name"  `shouldBe` (RepoPath $ RepoTemplatePath Bitbucket "user" "name.hsfiles")-        pathOf "gitlab:user/name"     `shouldBe` (RepoPath $ RepoTemplatePath Gitlab    "user" "name.hsfiles")+        pathOf "github:user/name"     `shouldBe` RepoPath (RepoTemplatePath Github    "user" "name.hsfiles")+        pathOf "bitbucket:user/name"  `shouldBe` RepoPath (RepoTemplatePath Bitbucket "user" "name.hsfiles")+        pathOf "gitlab:user/name"     `shouldBe` RepoPath (RepoTemplatePath Gitlab    "user" "name.hsfiles")          pathOf "http://www.com/file"  `shouldBe` UrlPath "http://www.com/file"         pathOf "https://www.com/file" `shouldBe` UrlPath "https://www.com/file" -        pathOf "name"                 `shouldBe` (RelPath $ Path "name.hsfiles")-        pathOf "name.hsfile"          `shouldBe` (RelPath $ Path "name.hsfile.hsfiles")-        pathOf "name.hsfiles"         `shouldBe` (RelPath $ Path "name.hsfiles")-        pathOf ""                     `shouldBe` (RelPath $ Path ".hsfiles")+        pathOf "name"                 `shouldBe` RelPath "name.hsfiles"        (Path "name.hsfiles")+        pathOf "name.hsfile"          `shouldBe` RelPath "name.hsfile.hsfiles" (Path "name.hsfile.hsfiles")+        pathOf "name.hsfiles"         `shouldBe` RelPath "name.hsfiles"        (Path "name.hsfiles")+        pathOf ""                     `shouldBe` RelPath ".hsfiles"            (Path ".hsfiles")          if os == "mingw32"         then do-          pathOf "//home/file"          `shouldBe` (AbsPath $ Path "\\\\home\\file.hsfiles")-          pathOf "/home/file"           `shouldBe` (RelPath $ Path "\\home\\file.hsfiles")-          pathOf "/home/file.hsfiles"   `shouldBe` (RelPath $ Path "\\home\\file.hsfiles")+          pathOf "//home/file"          `shouldBe` AbsPath (Path "\\\\home\\file.hsfiles")+          pathOf "/home/file"           `shouldBe` RelPath "/home/file.hsfiles" (Path "\\home\\file.hsfiles")+          pathOf "/home/file.hsfiles"   `shouldBe` RelPath "/home/file.hsfiles" (Path "\\home\\file.hsfiles") -          pathOf "c:\\home\\file"       `shouldBe` (AbsPath $ Path "C:\\home\\file.hsfiles")-          pathOf "with/slash"           `shouldBe` (RelPath $ Path "with\\slash.hsfiles")+          pathOf "c:\\home\\file"       `shouldBe` AbsPath                      (Path "C:\\home\\file.hsfiles")+          pathOf "with/slash"           `shouldBe` RelPath "with/slash.hsfiles" (Path "with\\slash.hsfiles")            let colonAction =                 do@@ -41,11 +41,11 @@           colonAction `shouldThrow` anyErrorCall          else do-          pathOf "//home/file"          `shouldBe` (AbsPath $ Path "/home/file.hsfiles")-          pathOf "/home/file"           `shouldBe` (AbsPath $ Path "/home/file.hsfiles")-          pathOf "/home/file.hsfiles"   `shouldBe` (AbsPath $ Path "/home/file.hsfiles")+          pathOf "//home/file"          `shouldBe` AbsPath (Path "/home/file.hsfiles")+          pathOf "/home/file"           `shouldBe` AbsPath (Path "/home/file.hsfiles")+          pathOf "/home/file.hsfiles"   `shouldBe` AbsPath (Path "/home/file.hsfiles") -          pathOf "c:\\home\\file"       `shouldBe` (RelPath $ Path "c:\\home\\file.hsfiles")-          pathOf "with/slash"           `shouldBe` (RelPath $ Path "with/slash.hsfiles")-          pathOf "with:colon"           `shouldBe` (RelPath $ Path "with:colon.hsfiles")+          pathOf "c:\\home\\file"       `shouldBe` RelPath "c:\\home\\file.hsfiles" (Path "c:\\home\\file.hsfiles")+          pathOf "with/slash"           `shouldBe` RelPath "with/slash.hsfiles"     (Path "with/slash.hsfiles")+          pathOf "with:colon"           `shouldBe` RelPath "with:colon.hsfiles"     (Path "with:colon.hsfiles")
− src/test/Stack/Untar/UntarSpec.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Stack.Untar.UntarSpec where--import Data.List (sort)-import Path-import Path.IO (removeDirRecur)-import qualified System.FilePath as FP-import Stack.Fetch (untar)-import Stack.Prelude-import Test.Hspec--spec :: Spec-spec = do-    describe "Untarring ignores strange entries" $-      mapM_ testTarFile tarFiles-  where-    -- XXX tests are run in the project root folder, but data files are next to-    -- this source data.-    currentFolder = $(mkRelDir $ "src" FP.</> "test" FP.</> "Stack" FP.</> "Untar")--    -- Pairs test tarball names + list of unexpected entries contained: for each-    -- entry, a tar pathname + description.-    tarFilesBase = [ ("test1", [])-                   , ("test2", [ ("bar", "named pipe")-                               , ("devB", "block device")-                               , ("devC", "character device")])]-    -- Prepend tarball name to tar pathnames:-    tarFiles =-      [ (name,-         [ (name FP.</> entryName, d)-         | (entryName, d) <- entries])-      | (name, entries) <- tarFilesBase ]--    testTarFile (name, expected) =-      it ("works on test " ++ name) $-        getEntries name `shouldReturn` sort expected--    getEntries name = do-      tarballName <- parseRelFile $ name ++ ".tar.gz"-      expectedTarFolder <- parseRelDir name--      entries <- untar (currentFolder </> tarballName) expectedTarFolder currentFolder-      removeDirRecur $ currentFolder </> expectedTarFolder-      return $ sort entries
+ src/test/Stack/UploadSpec.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Stack.UploadSpec (spec) where++import RIO+import RIO.Directory+import RIO.FilePath ((</>))+import Stack.Upload+import Test.Hspec+import System.Permissions (osIsWindows)+import System.PosixCompat.Files (getFileStatus, fileMode)+import Data.Bits ((.&.))++spec :: Spec+spec = do+  it "writeFilePrivate" $ example $ withSystemTempDirectory "writeFilePrivate" $ \dir -> replicateM_ 2 $ do+    let fp = dir </> "filename"+        contents :: IsString s => s+        contents = "These are the contents"+    writeFilePrivate fp contents+    actual <- readFileBinary fp+    actual `shouldBe` contents+    perms <- getPermissions fp+    perms `shouldBe` setOwnerWritable True (setOwnerReadable True emptyPermissions)++    unless osIsWindows $ do+      status <- getFileStatus fp+      (fileMode status .&. 0o777) `shouldBe` 0o600
− src/test/Test.hs 
@@ -1,5 +0,0 @@-import Test.Hspec (hspec)-import Spec (spec)--main :: IO ()-main = hspec spec
− src/unix/Stack/DefaultColorWhen.hs 
@@ -1,11 +0,0 @@-{- | This version of the module is only for non-Windows (eg unix-like)-operating systems.--}-module Stack.DefaultColorWhen-  ( defaultColorWhen-  ) where--import Stack.Types.Runner (ColorWhen (ColorAuto))--defaultColorWhen :: IO ColorWhen-defaultColorWhen = return ColorAuto
+ src/unix/System/Info/ShortPathName.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE NoImplicitPrelude #-}++module System.Info.ShortPathName+  ( getShortPathName+  ) where++import RIO.FilePath (FilePath)+import RIO.Prelude (pure)+import RIO.Prelude.Types (IO)++getShortPathName :: FilePath -> IO FilePath+getShortPathName = pure
+ src/unix/System/Permissions.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE NoImplicitPrelude #-}+module System.Permissions+  ( setScriptPerms+  , osIsWindows+  , setFileExecutable+  ) where++import qualified System.Posix.Files as Posix+import RIO++-- | True if using Windows OS.+osIsWindows :: Bool+osIsWindows = False++setScriptPerms :: MonadIO m => FilePath -> m ()+setScriptPerms fp = do+    liftIO $ Posix.setFileMode fp $+        Posix.ownerReadMode `Posix.unionFileModes`+        Posix.ownerWriteMode `Posix.unionFileModes`+        Posix.groupReadMode `Posix.unionFileModes`+        Posix.otherReadMode++setFileExecutable :: MonadIO m => FilePath -> m ()+setFileExecutable fp = liftIO $ Posix.setFileMode fp 0o755
src/unix/System/Terminal.hsc view
@@ -1,35 +1,14 @@-{-# LANGUAGE ForeignFunctionInterface #-}- module System.Terminal-( getTerminalWidth+( fixCodePage+, hIsTerminalDeviceOrMinTTY ) where -import           Foreign-import           Foreign.C.Types--#include <sys/ioctl.h>-#include <unistd.h>--newtype WindowWidth = WindowWidth CUShort-    deriving (Eq, Ord, Show)--instance Storable WindowWidth where-  sizeOf _ = (#size struct winsize)-  alignment _ = (#alignment struct winsize)-  peek p = WindowWidth <$> (#peek struct winsize, ws_col) p-  poke p (WindowWidth w) = do-    (#poke struct winsize, ws_col) p w+import           RIO (MonadIO, Handle, hIsTerminalDevice) -foreign import ccall "sys/ioctl.h ioctl"-  ioctl :: CInt -> CInt -> Ptr WindowWidth -> IO CInt+fixCodePage :: x -> y -> a -> a+fixCodePage _ _ = id --- | Get the width, in columns, of the terminal if we can.-getTerminalWidth :: IO (Maybe Int)-getTerminalWidth =-  alloca $ \p -> do-    errno <- ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) p-    if errno < 0-      then return Nothing-      else do-        WindowWidth w <- peek p-        return . Just . fromIntegral $ w+-- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal+-- devices, but isMinTTYHandle does.+hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool+hIsTerminalDeviceOrMinTTY = hIsTerminalDevice
+ src/unix/System/Uname.hsc view
@@ -0,0 +1,40 @@+module System.Uname+    ( getRelease+    )+    where++#include <sys/utsname.h>++import Foreign+import Foreign.C++getRelease :: IO String+getRelease = do+  alloca $ \ ptr ->+             do throwErrnoIfMinus1_ "uname" $ uname ptr+                peekCString $ release ptr+-- | @'uname' name@ stores nul-terminated strings of information+--   identifying the current system info to the structure referenced+--   by name.+--+--   > import Foreign.C+--   > import Foreign.Marshal+--   >+--   > sysName :: IO String+--   > sysName = alloca $ \ ptr ->+--   >           do throwErrnoIfMinus1_ "uname" $ uname ptr+--   >              peekCString $ sysname ptr+--+foreign import ccall unsafe "haskell_uname"+        uname :: Ptr Utsname -> IO CInt++data Utsname++instance Storable Utsname where+    sizeOf    = const #size struct utsname+    alignment = const #alignment struct utsname+    poke      = error "Storable Utsname: peek: unsupported operation"+    peek      = error "Storable Utsname: poke: unsupported operation"++release :: Ptr Utsname -> CString+release = (#ptr struct utsname, release)
+ src/unix/cbits/uname.c view
@@ -0,0 +1,6 @@+#include <sys/utsname.h>++int haskell_uname(struct utsname *name)+{+    return uname(name);+}
− src/windows/Stack/DefaultColorWhen.hs 
@@ -1,65 +0,0 @@-{-# LANGUAGE CPP #-}--{- | This version of the module is only for Windows operating systems.--}-module Stack.DefaultColorWhen-  ( defaultColorWhen-  ) where---- The Win32 package provides CPP macro WINDOWS_CCONV.-#include "windows_cconv.h"--import Stack.Prelude (stdout)-import Stack.Types.Runner (ColorWhen (ColorAuto, ColorNever))--import Data.Bits ((.|.), (.&.))-import Foreign.Marshal (alloca)-import Foreign.Ptr (Ptr)-import Foreign.Storable (peek)-import System.Win32.Types (BOOL, DWORD, HANDLE, iNVALID_HANDLE_VALUE,-  nullHANDLE, withHandleToHANDLE)--defaultColorWhen :: IO ColorWhen-defaultColorWhen = withHandleToHANDLE stdout aNSISupport---- The following is based on extracts from the modules--- System.Console.ANSI.Windows.Foreign and System.Console.ANSI.Windows.Detect--- from the ansi-terminal package, simplified.---- | This function first checks if the Windows handle is valid and yields--- 'never' if it is not. It then tries to get a ConHost console mode for that--- handle. If it can not, it assumes that the handle is ANSI-enabled. If virtual--- termimal (VT) processing is already enabled, the handle supports 'auto'.--- Otherwise, it trys to enable processing. If it can, the handle supports--- 'auto'. If it can not, the function yields 'never'.-aNSISupport :: HANDLE -> IO ColorWhen-aNSISupport h =-  if h == iNVALID_HANDLE_VALUE || h == nullHANDLE-    then return ColorNever  -- Invalid handle or no handle-    else do-      tryMode <- getConsoleMode h-      case tryMode of-        Nothing     -> return ColorAuto  -- No ConHost mode-        Just mode   -> if mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0-          then return ColorAuto  -- VT processing already enabled-          else do-            let mode' = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING-            succeeded <- cSetConsoleMode h mode'-            if succeeded-              then return ColorAuto  -- VT processing enabled-              else return ColorNever -- Can't enable VT processing- where-  eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4--foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode"-  cGetConsoleMode :: HANDLE -> Ptr DWORD -> IO BOOL--foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode"-  cSetConsoleMode :: HANDLE -> DWORD -> IO BOOL--getConsoleMode :: HANDLE -> IO (Maybe DWORD)-getConsoleMode handle = alloca $ \ptr_mode -> do-  succeeded <- cGetConsoleMode handle ptr_mode-  if succeeded-    then Just <$> peek ptr_mode-    else pure Nothing
+ src/windows/System/Info/ShortPathName.hs view
@@ -0,0 +1,5 @@+module System.Info.ShortPathName+  ( getShortPathName+  ) where++import System.Win32.Info (getShortPathName)
+ src/windows/System/Permissions.hs view
@@ -0,0 +1,15 @@+module System.Permissions+  ( setScriptPerms+  , osIsWindows+  , setFileExecutable+  ) where++-- | True if using Windows OS.+osIsWindows :: Bool+osIsWindows = True++setScriptPerms :: Monad m => FilePath -> m ()+setScriptPerms _ = return ()++setFileExecutable :: Monad m => FilePath -> m ()+setFileExecutable _ = return ()
src/windows/System/Terminal.hs view
@@ -1,6 +1,66 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} module System.Terminal-( getTerminalWidth+( fixCodePage+, hIsTerminalDeviceOrMinTTY ) where--- | Get the width, in columns, of the terminal if we can.-getTerminalWidth :: IO (Maybe Int)-getTerminalWidth = return Nothing++import Distribution.Types.Version (mkVersion)+import Stack.Prelude+import System.Win32 (isMinTTYHandle, withHandleToHANDLE)+import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP)++-- | Set the code page for this process as necessary. Only applies to Windows.+-- See: https://github.com/commercialhaskell/stack/issues/738+fixCodePage+  :: HasLogFunc env+  => Bool -- ^ modify code page?+  -> Version -- ^ GHC version+  -> RIO env a+  -> RIO env a+fixCodePage mcp ghcVersion inner = do+    if mcp && ghcVersion < mkVersion [7, 10, 3]+        then fixCodePage'+        -- GHC >=7.10.3 doesn't need this code page hack.+        else inner+  where+    fixCodePage' = do+        origCPI <- liftIO getConsoleCP+        origCPO <- liftIO getConsoleOutputCP++        let setInput = origCPI /= expected+            setOutput = origCPO /= expected+            fixInput+                | setInput = bracket_+                    (liftIO $ do+                        setConsoleCP expected)+                    (liftIO $ setConsoleCP origCPI)+                | otherwise = id+            fixOutput+                | setOutput = bracket_+                    (liftIO $ do+                        setConsoleOutputCP expected)+                    (liftIO $ setConsoleOutputCP origCPO)+                | otherwise = id++        case (setInput, setOutput) of+            (False, False) -> return ()+            (True, True) -> warn ""+            (True, False) -> warn " input"+            (False, True) -> warn " output"++        fixInput $ fixOutput inner+    expected = 65001 -- UTF-8+    warn typ = logInfo $+        "Setting" <>+        typ <>+        " codepage to UTF-8 (65001) to ensure correct output from GHC"++-- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal+-- devices, but isMinTTYHandle does.+hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool+hIsTerminalDeviceOrMinTTY h = do+  isTD <- hIsTerminalDevice h+  if isTD+    then return True+    else liftIO $ withHandleToHANDLE h isMinTTYHandle
+ src/windows/System/Uname.hs view
@@ -0,0 +1,6 @@+module System.Uname+  ( getRelease+  ) where++getRelease :: IO String+getRelease = error "getRelease not supported on Windows"
stack.cabal view
@@ -1,13 +1,13 @@-cabal-version: 1.24+cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack ----- hash: 4660c8af471b9e6d591f3414122079e0f1d8ee984995ed25cf46c4b01ed78b66+-- hash: ab5fa5e0e456ff3ea13448d37fb37c3fcdf00a887b893daf5a6ff799421b383d  name:           stack-version:        1.9.3.1+version:        2.1.1 synopsis:       The Haskell Tool Stack description:    Please see the README.md for usage information, and the wiki on Github for more details.  Also, note that the API for the library is not currently stable, and may change significantly, even between minor releases. It is currently only intended for use by the executable. category:       Development@@ -22,21 +22,25 @@     CONTRIBUTING.md     ChangeLog.md     README.md-    doc/architecture.md+    doc/azure_ci.md     doc/build_command.md+    doc/build_overview.md     doc/ChangeLog.md     doc/CONTRIBUTING.md     doc/coverage.md     doc/custom_snapshot.md     doc/dependency_visualization.md+    doc/developing_on_windows.md     doc/docker_integration.md     doc/faq.md     doc/ghci.md     doc/ghcjs.md     doc/GUIDE.md     doc/install_and_upgrade.md+    doc/lock_files.md     doc/nix_integration.md     doc/nonstandard_project_init.md+    doc/pantry.md     doc/README.md     doc/shell_autocompletion.md     doc/SIGNING_KEY.md@@ -90,15 +94,10 @@ library   exposed-modules:       Control.Concurrent.Execute-      Data.Aeson.Extended       Data.Attoparsec.Args       Data.Attoparsec.Combinators       Data.Attoparsec.Interpreter-      Data.IORef.RunOnce       Data.Monoid.Map-      Data.Store.VersionTagged-      Network.HTTP.Download-      Network.HTTP.Download.Verified       Network.HTTP.StackClient       Options.Applicative.Args       Options.Applicative.Builder.Extra@@ -106,7 +105,6 @@       Path.CheckInstall       Path.Extra       Path.Find-      Paths_stack       Stack.Build       Stack.Build.Cache       Stack.Build.ConstructPlan@@ -119,7 +117,6 @@       Stack.Clean       Stack.Config       Stack.Config.Build-      Stack.Config.Urls       Stack.Config.Docker       Stack.Config.Nix       Stack.ConfigCmd@@ -128,18 +125,17 @@       Stack.Coverage       Stack.DefaultColorWhen       Stack.Docker-      Stack.Docker.GlobalDB       Stack.Dot-      Stack.Fetch       Stack.FileWatch+      Stack.Freeze       Stack.GhcPkg       Stack.Ghci       Stack.Ghci.Script       Stack.Hoogle       Stack.IDE-      Stack.Image       Stack.Init       Stack.Ls+      Stack.Lock       Stack.New       Stack.Nix       Stack.Options.BenchParser@@ -151,6 +147,7 @@       Stack.Options.DockerParser       Stack.Options.DotParser       Stack.Options.ExecParser+      Stack.Options.FreezeParser       Stack.Options.GhcBuildParser       Stack.Options.GhciParser       Stack.Options.GhcVariantParser@@ -164,59 +161,48 @@       Stack.Options.ResolverParser       Stack.Options.ScriptParser       Stack.Options.SDistParser-      Stack.Options.SolverParser       Stack.Options.TestParser       Stack.Options.Utils       Stack.Package       Stack.PackageDump-      Stack.PackageIndex-      Stack.PackageLocation       Stack.Path       Stack.Prelude-      Stack.PrettyPrint       Stack.Runners       Stack.Script       Stack.SDist       Stack.Setup       Stack.Setup.Installed       Stack.SetupCmd-      Stack.Sig-      Stack.Sig.GPG-      Stack.Sig.Sign-      Stack.Snapshot-      Stack.Solver-      Stack.StaticBytes+      Stack.SourceMap+      Stack.Storage       Stack.Types.Build-      Stack.Types.BuildPlan       Stack.Types.CompilerBuild-      Stack.Types.Urls       Stack.Types.Compiler       Stack.Types.Config       Stack.Types.Config.Build       Stack.Types.Docker-      Stack.Types.FlagName       Stack.Types.GhcPkgId-      Stack.Types.Image       Stack.Types.NamedComponent       Stack.Types.Nix       Stack.Types.Package-      Stack.Types.PackageDump-      Stack.Types.PackageIdentifier-      Stack.Types.PackageIndex       Stack.Types.PackageName       Stack.Types.Resolver-      Stack.Types.Runner-      Stack.Types.Sig+      Stack.Types.SourceMap       Stack.Types.TemplateName       Stack.Types.Version       Stack.Types.VersionIntervals+      Stack.Unpack       Stack.Upgrade       Stack.Upload-      Text.PrettyPrint.Leijen.Extended-      System.Process.PagerEditor+      System.Info.ShortPathName+      System.Permissions+      System.Process.Pager       System.Terminal+      Paths_stack   other-modules:-      Hackage.Security.Client.Repository.HttpLib.HttpClient+      Stack.Types.Cache+  autogen-modules:+      Paths_stack   hs-source-dirs:       src/   ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -optP-Wno-nonportable-include-path -fwarn-identities@@ -225,11 +211,13 @@     , aeson     , annotated-wl-pprint     , ansi-terminal+    , array     , async     , attoparsec     , base >=4.10 && <5     , base64-bytestring     , bytestring+    , colour     , conduit     , conduit-extra     , containers@@ -247,16 +235,17 @@     , generic-deriving     , hackage-security     , hashable+    , hi-file-parser     , hpack     , hpc     , http-client     , http-client-tls     , http-conduit+    , http-download     , http-types     , memory     , microlens     , mintty-    , monad-logger     , mono-traversable     , mtl     , mustache@@ -264,6 +253,7 @@     , network-uri     , open-browser     , optparse-applicative+    , pantry-tmp     , path     , path-io     , persistent@@ -274,18 +264,19 @@     , process     , project-template     , regex-applicative-text+    , resource-pool     , resourcet     , retry     , rio+    , rio-prettyprint     , semigroups     , split     , stm-    , store-    , store-core     , streaming-commons     , tar     , template-haskell     , temporary+    , terminal-size     , text     , text-metrics     , th-reify-many@@ -309,22 +300,30 @@     build-tools:         hsc2hs     build-depends:-        bindings-uname-      , unix+        unix   if os(windows)+    other-modules:+        System.Uname     hs-source-dirs:         src/windows/   else+    other-modules:+        System.Uname     hs-source-dirs:         src/unix/+    c-sources:+        src/unix/cbits/uname.c   default-language: Haskell2010-  autogen-modules: Paths_stack  executable stack   main-is: Main.hs   other-modules:+      BuildInfo       Build_stack       Paths_stack+  autogen-modules:+      Build_stack+      Paths_stack   hs-source-dirs:       src/main   ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -optP-Wno-nonportable-include-path -threaded -rtsopts@@ -333,11 +332,13 @@     , aeson     , annotated-wl-pprint     , ansi-terminal+    , array     , async     , attoparsec     , base >=4.10 && <5     , base64-bytestring     , bytestring+    , colour     , conduit     , conduit-extra     , containers@@ -355,16 +356,17 @@     , generic-deriving     , hackage-security     , hashable+    , hi-file-parser     , hpack     , hpc     , http-client     , http-client-tls     , http-conduit+    , http-download     , http-types     , memory     , microlens     , mintty-    , monad-logger     , mono-traversable     , mtl     , mustache@@ -372,6 +374,7 @@     , network-uri     , open-browser     , optparse-applicative+    , pantry-tmp     , path     , path-io     , persistent@@ -382,19 +385,20 @@     , process     , project-template     , regex-applicative-text+    , resource-pool     , resourcet     , retry     , rio+    , rio-prettyprint     , semigroups     , split     , stack     , stm-    , store-    , store-core     , streaming-commons     , tar     , template-haskell     , temporary+    , terminal-size     , text     , text-metrics     , th-reify-many@@ -418,8 +422,7 @@     build-tools:         hsc2hs     build-depends:-        bindings-uname-      , unix+        unix   if flag(static)     ld-options: -static -pthread   if !(flag(disable-git-info))@@ -432,12 +435,8 @@   if flag(supported-build)     cpp-options: -DSUPPORTED_BUILD   default-language: Haskell2010-  autogen-modules:-      Build_stack,-      Paths_stack -test-suite stack-integration-test-  type: exitcode-stdio-1.0+executable stack-integration-test   main-is: IntegrationSpec.hs   other-modules:       StackTest@@ -451,11 +450,13 @@     , aeson     , annotated-wl-pprint     , ansi-terminal+    , array     , async     , attoparsec     , base >=4.10 && <5     , base64-bytestring     , bytestring+    , colour     , conduit     , conduit-extra     , containers@@ -473,17 +474,18 @@     , generic-deriving     , hackage-security     , hashable+    , hi-file-parser     , hpack     , hpc     , hspec     , http-client     , http-client-tls     , http-conduit+    , http-download     , http-types     , memory     , microlens     , mintty-    , monad-logger     , mono-traversable     , mtl     , mustache@@ -491,6 +493,8 @@     , network-uri     , open-browser     , optparse-applicative+    , optparse-generic+    , pantry-tmp     , path     , path-io     , persistent@@ -501,18 +505,19 @@     , process     , project-template     , regex-applicative-text+    , resource-pool     , resourcet     , retry     , rio+    , rio-prettyprint     , semigroups     , split     , stm-    , store-    , store-core     , streaming-commons     , tar     , template-haskell     , temporary+    , terminal-size     , text     , text-metrics     , th-reify-many@@ -536,34 +541,29 @@     build-tools:         hsc2hs     build-depends:-        bindings-uname-      , unix+        unix   if !(flag(integration-tests))     buildable: False   default-language: Haskell2010  test-suite stack-test   type: exitcode-stdio-1.0-  main-is: Test.hs+  main-is: Spec.hs   other-modules:-      Network.HTTP.Download.VerifiedSpec-      Spec       Stack.ArgsSpec       Stack.Build.ExecuteSpec       Stack.Build.TargetSpec+      Stack.Config.DockerSpec       Stack.ConfigSpec       Stack.DotSpec       Stack.Ghci.PortableFakePaths       Stack.Ghci.ScriptSpec       Stack.GhciSpec+      Stack.LockSpec       Stack.NixSpec       Stack.PackageDumpSpec-      Stack.SolverSpec-      Stack.StaticBytesSpec-      Stack.StoreSpec-      Stack.Types.BuildPlanSpec       Stack.Types.TemplateNameSpec-      Stack.Untar.UntarSpec+      Stack.UploadSpec       Paths_stack   hs-source-dirs:       src/test@@ -574,11 +574,13 @@     , aeson     , annotated-wl-pprint     , ansi-terminal+    , array     , async     , attoparsec     , base >=4.10 && <5     , base64-bytestring     , bytestring+    , colour     , conduit     , conduit-extra     , containers@@ -596,17 +598,18 @@     , generic-deriving     , hackage-security     , hashable+    , hi-file-parser     , hpack     , hpc     , hspec     , http-client     , http-client-tls     , http-conduit+    , http-download     , http-types     , memory     , microlens     , mintty-    , monad-logger     , mono-traversable     , mtl     , mustache@@ -614,6 +617,7 @@     , network-uri     , open-browser     , optparse-applicative+    , pantry-tmp     , path     , path-io     , persistent@@ -623,21 +627,23 @@     , primitive     , process     , project-template+    , raw-strings-qq     , regex-applicative-text+    , resource-pool     , resourcet     , retry     , rio+    , rio-prettyprint     , semigroups     , smallcheck     , split     , stack     , stm-    , store-    , store-core     , streaming-commons     , tar     , template-haskell     , temporary+    , terminal-size     , text     , text-metrics     , th-reify-many@@ -661,6 +667,5 @@     build-tools:         hsc2hs     build-depends:-        bindings-uname-      , unix+        unix   default-language: Haskell2010
stack.yaml view
@@ -1,5 +1,13 @@-resolver: lts-11.22+resolver: snapshot.yaml +packages:+- .+- subs/pantry+- subs/curator+- subs/http-download+- subs/rio-prettyprint+- subs/hi-file-parser+ # docker: #   enable: true #   repo: fpco/stack-full@@ -16,31 +24,6 @@   stack:     hide-dependency-versions: true     supported-build: true-extra-deps:-- Cabal-2.4.0.1@rev:0-- cabal-install-2.4.0.0@rev:1-- resolv-0.1.1.2@rev:0-- infer-license-0.2.0@rev:0 #for hpack-0.31-- hpack-0.31.1@rev:0-- http-api-data-0.3.8.1@rev:1-- githash-0.1.3.0@rev:0-- yaml-0.10.4.0@rev:0 #for hpack-0.31-- windns-0.1.0.0@rev:0-- hackage-security-0.5.3.0@rev:2-- cabal-doctest-1.0.6@rev:2-- rio-0.1.9.2@rev:0-- unliftio-0.2.10@rev:0--# Avoid https://github.com/commercialhaskell/stack/issues/4125-# (triggered because later versions of persistent transitively depends-# on haskell-src-exts, which needs the 'happy' build tool)-# THIS IS FIXED AS OF STACK 1.8, but keep these here until next major-# version to maintain the ability to build stack with older versions.-- persistent-2.7.1@rev:0-- persistent-sqlite-2.6.4@rev:0-- resourcet-1.1.11@rev:0-- conduit-1.2.13.1@rev:0-- conduit-extra-1.2.3.2@rev:0  ghc-options:    "$locals": -fhide-source-paths
test/integration/IntegrationSpec.hs view
@@ -1,142 +1,254 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-} -import           Control.Applicative-import           Control.Arrow-import           Control.Concurrent.Async-import           Control.Exception-import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Resource-import qualified Data.ByteString.Lazy         as L-import           Data.Char-import           Data.Conduit-import           Data.Conduit.Binary          (sinkLbs)-import           Data.Conduit.Filesystem      (sourceDirectoryDeep)-import qualified Data.Conduit.List            as CL-import           Data.Conduit.Process-import           Data.List                    (isSuffixOf, stripPrefix, sort)-import qualified Data.Map                     as Map-import           Data.Maybe                   (fromMaybe)-import           Data.Text.Encoding.Error     (lenientDecode)-import qualified Data.Text.Lazy               as TL-import qualified Data.Text.Lazy.Encoding      as TL-import           Data.Typeable-import           Prelude -- Fix redundant import warnings-import           System.Directory-import           System.Environment-import           System.Exit-import           System.FilePath-import           System.IO.Temp+import           Conduit+import           Data.List                (stripPrefix)+import           Options.Generic+import           RIO+import           RIO.Char                 (toLower)+import           RIO.Directory            hiding (findExecutable)+import           RIO.FilePath+import           RIO.List                 (isInfixOf, partition)+import qualified RIO.Map                  as Map+import           RIO.Process+import qualified RIO.Set                  as Set+import qualified RIO.Text                 as T+import           System.Environment       (lookupEnv, getExecutablePath)+import           System.Info (os) import           System.PosixCompat.Files-import           Test.Hspec +-- This code does not use a test framework so that we get direct+-- control of how the output is displayed.+ main :: IO ()-main = do-    currDir <- canonicalizePath "test/integration"+main = runSimpleApp $ do+  logInfo "Initiating Stack integration test running" -    let findExe name = do-            mexe <- findExecutable name-            case mexe of-                Nothing -> error $ name ++ " not found on PATH"-                Just exe -> return exe-    runghc <- findExe "runghc"-    stack <- findExe "stack"+  options <- getRecord "Stack integration tests"+  results <- runApp options $ do+    logInfo "Running with the following environment"+    proc "env" [] runProcess_+    tests <- asks appTestDirs+    let count = Set.size tests+        loop !idx rest !accum =+          case rest of+            [] -> pure accum+            next:rest' -> do+              logInfo $ "Running integration test "+                     <> display idx+                     <> "/"+                     <> display count+                     <> ": "+                     <> fromString (takeFileName next)+              res <- test next+              loop (idx + 1) rest' (res <> accum) -    let testDir = currDir </> "tests"-    tests <- getDirectoryContents testDir >>= filterM (hasTest testDir) . sort+    loop (1 :: Int) (Set.toList tests) mempty -    envOrig <- getEnvironment+  let (successes, failures) = partition ((== ExitSuccess) . snd)+                            $ Map.toList results -    withSystemTempDirectory "stackhome" $ \newHome -> do-        defaultStackRoot <- getAppUserDataDirectory "stack"-        let newStackRoot = newHome </> takeFileName defaultStackRoot-            env' = Map.toList-                 $ Map.insert "STACK_EXE" stack-                 $ Map.insert "HOME" newHome-                 $ Map.insert "APPDATA" newHome-                 $ Map.insert "STACK_ROOT" newStackRoot-                 $ Map.delete "GHC_PACKAGE_PATH"-                 $ Map.fromList-                 $ map (first (map toUpper)) envOrig-            origStackRoot = fromMaybe defaultStackRoot (lookup "STACK_ROOT" envOrig)+  unless (null successes) $ do+    logInfo "Successful tests:"+    for_ successes $ \(x, _) -> logInfo $ "- " <> display x+    logInfo "" -        hspec $ mapM_ (test runghc env' currDir origStackRoot newHome newStackRoot) tests+  if null failures+    then logInfo "No failures!"+    else do+      logInfo "Failed tests:"+      for_ failures $ \(x, ec) -> logInfo $ "- " <> display x <> " - " <> displayShow ec+      exitFailure -hasTest :: FilePath -> FilePath -> IO Bool-hasTest root dir = doesFileExist $ root </> dir </> "Main.hs"+data Options = Options+  { optSpeed :: Maybe Speed+  , optMatch :: Maybe String+  } deriving Generic -test :: FilePath -- ^ runghc-     -> [(String, String)] -- ^ env-     -> FilePath -- ^ currdir-     -> FilePath -- ^ origStackRoot-     -> FilePath -- ^ newHome-     -> FilePath -- ^ newStackRoot-     -> String-     -> Spec-test runghc env' currDir origStackRoot newHome newStackRoot name = it name $ withDir $ \dir -> do-    newHomeExists <- doesDirectoryExist newHome-    when newHomeExists (removeDirectoryRecursive newHome)-    createDirectoryIfMissing True newStackRoot-    copyTree toCopyRoot origStackRoot newStackRoot-    writeFile (newStackRoot </> "config.yaml") "system-ghc: true\ninstall-ghc: false\n"-    let testDir = currDir </> "tests" </> name-        mainFile = testDir </> "Main.hs"-        libDir = currDir </> "lib"-        cp = (proc runghc-                [ "-clear-package-db"-                , "-global-package-db"-                , "-i" ++ libDir-                , mainFile-                ])-                { cwd = Just dir-                , env = Just env'-                }+instance ParseRecord Options where+  parseRecord = parseRecordWithModifiers modifiers+    where+      optName = map toLower . drop 3+      modifiers = defaultModifiers { fieldNameModifier = optName+                                   , shortNameModifier = firstLetter . optName+                                   } -    copyTree (const True) (testDir </> "files") dir+data Speed = Fast | Normal | Superslow+  deriving (Read, Generic) -    (ClosedStream, outSrc, errSrc, sph) <- streamingProcess cp-    (out, err, ec) <- runConcurrently $ (,,)-        <$> Concurrently (outSrc `connect` sinkLbs)-        <*> Concurrently (errSrc `connect` sinkLbs)-        <*> Concurrently (waitForStreamingProcess sph)-    when (ec /= ExitSuccess) $ throwIO $ TestFailure out err ec+instance ParseField Speed++exeExt :: String+exeExt = if isWindows then ".exe" else ""++isWindows :: Bool+isWindows = os == "mingw32"++runApp :: Options -> RIO App a -> RIO SimpleApp a+runApp options inner = do+  let speed = fromMaybe Normal $ optSpeed options+  simpleApp <- ask+  runghc <- findExecutable "runghc" >>= either throwIO pure+  srcDir <- canonicalizePath ""+  testsRoot <- canonicalizePath $ srcDir </> "test/integration"+  libdir <- canonicalizePath $ testsRoot </> "lib"+  myPath <- liftIO getExecutablePath++  stack <- canonicalizePath $ takeDirectory myPath </> "stack" ++ exeExt+  logInfo $ "Using stack located at " <> fromString stack+  proc stack ["--version"] runProcess_++  let matchTest = case optMatch options of+        Nothing -> const True+        Just str -> (str `isInfixOf`)+  testDirs+    <- runConduitRes+     $ sourceDirectory (testsRoot </> "tests")+    .| filterMC (liftIO . hasTest)+    .| filterC matchTest+    .| foldMapC Set.singleton++  let modifyEnvCommon+        = Map.insert "SRC_DIR" (fromString srcDir)+        . Map.insert "STACK_EXE" (fromString stack)+        . Map.delete "GHC_PACKAGE_PATH"+        . Map.insert "STACK_TEST_SPEED"+            (case speed of+              Superslow -> "SUPERSLOW"+              _ -> "NORMAL")+        . Map.fromList+        . map (first T.toUpper)+        . Map.toList++  case speed of+    Fast -> do+      let app = App+            { appSimpleApp = simpleApp+            , appRunghc = runghc+            , appLibDir = libdir+            , appSetupHome = id+            , appTestDirs = testDirs+            }+      runRIO app $ withModifyEnvVars modifyEnvCommon inner+    _ -> do+      morigStackRoot <- liftIO $ lookupEnv "STACK_ROOT"+      origStackRoot <-+        case morigStackRoot of+          Nothing -> getAppUserDataDirectory "stack"+          Just x -> pure x++      logInfo "Initializing/updating the original Pantry store"+      proc stack ["update"] runProcess_++      pantryRoot <- canonicalizePath $ origStackRoot </> "pantry"+      let modifyEnv+               = Map.insert "PANTRY_ROOT" (fromString pantryRoot)+               . modifyEnvCommon++          app = App+            { appSimpleApp = simpleApp+            , appRunghc = runghc+            , appLibDir = libdir+            , appSetupHome = \inner' -> withSystemTempDirectory "home" $ \newHome -> do+                let newStackRoot = newHome </> ".stack"+                createDirectoryIfMissing True newStackRoot+                let modifyEnv'+                      = Map.insert "HOME" (fromString newHome)+                      . Map.insert "APPDATA" (fromString newHome)+                      . Map.insert "STACK_ROOT" (fromString newStackRoot)+                writeFileBinary (newStackRoot </> "config.yaml") "system-ghc: true\ninstall-ghc: false\n"+                withModifyEnvVars modifyEnv' inner'+            , appTestDirs = testDirs+            }++      runRIO app $ withModifyEnvVars modifyEnv inner+++hasTest :: FilePath -> IO Bool+hasTest dir = doesFileExist $ dir </> "Main.hs"++data App = App+  { appRunghc :: !FilePath+  , appLibDir :: !FilePath+  , appSetupHome :: !(forall a. RIO App a -> RIO App a)+  , appSimpleApp :: !SimpleApp+  , appTestDirs :: !(Set FilePath)+  }+simpleAppL :: Lens' App SimpleApp+simpleAppL = lens appSimpleApp (\x y -> x { appSimpleApp = y })+instance HasLogFunc App where+  logFuncL = simpleAppL.logFuncL+instance HasProcessContext App where+  processContextL = simpleAppL.processContextL++-- | Call 'appSetupHome' on the inner action+withHome :: RIO App a -> RIO App a+withHome inner = do+  app <- ask+  appSetupHome app inner++test :: FilePath -- ^ test dir+     -> RIO App (Map Text ExitCode)+test testDir = withDir $ \dir -> withHome $ do+    runghc <- asks appRunghc+    libDir <- asks appLibDir+    let mainFile = testDir </> "Main.hs"++    copyTree (testDir </> "files") dir++    withSystemTempFile (name <.> "log") $ \logfp logh -> do+      ec <- withWorkingDir dir+          $ withModifyEnvVars (Map.insert "TEST_DIR" $ fromString testDir)+          $ proc runghc+              [ "-clear-package-db"+              , "-global-package-db"+              , "-i" ++ libDir+              , mainFile+              ]+           $ runProcess+           . setStdin closed+           . setStdout (useHandleOpen logh)+           . setStderr (useHandleOpen logh)+      hClose logh++      case ec of+        ExitSuccess -> logInfo "Success!"+        _ -> do+          logError "Failure, dumping log\n\n"+          withSourceFile logfp $ \src ->+            runConduit $ src .| stderrC+          logError $ "\n\nEnd of log for " <> fromString name+      pure $ Map.singleton (fromString name) ec   where+    name = takeFileName testDir     withDir = withSystemTempDirectory ("stack-integration-" ++ name) -data TestFailure = TestFailure L.ByteString L.ByteString ExitCode-    deriving Typeable-instance Show TestFailure where-    show (TestFailure out err ec) = concat-        [ "Exited with " ++ show ec-        , "\n\nstdout:\n"-        , toStr out-        , "\n\nstderr:\n"-        , toStr err-        ]-      where-        toStr = TL.unpack . TL.decodeUtf8With lenientDecode-instance Exception TestFailure--copyTree :: (FilePath -> Bool) -> FilePath -> FilePath -> IO ()-copyTree toCopy src dst =-    runResourceT (sourceDirectoryDeep False src `connect` CL.mapM_ go)+copyTree :: MonadIO m => FilePath -> FilePath -> m ()+copyTree src dst =+    liftIO $+    runResourceT (sourceDirectoryDeep False src `connect` mapM_C go)         `catch` \(_ :: IOException) -> return ()   where-    go srcfp = when (toCopy srcfp) $ liftIO $ do+    go srcfp = liftIO $ do         Just suffix <- return $ stripPrefix src srcfp-        let dstfp = dst ++ "/" ++ suffix+        let dstfp = dst </> stripHeadSeparator suffix         createDirectoryIfMissing True $ takeDirectory dstfp-        createSymbolicLink srcfp dstfp `catch` \(_ :: IOException) ->-            copyFile srcfp dstfp -- for Windows+        -- copying yaml files so lock files won't get created in+        -- the source directory+        if takeFileName srcfp /= "package.yaml" &&+           (takeExtensions srcfp == ".yaml" || takeExtensions srcfp == ".yml")+          then+            copyFile srcfp dstfp+          else+            createSymbolicLink srcfp dstfp `catch` \(_ :: IOException) ->+                copyFile srcfp dstfp -- for Windows -toCopyRoot :: FilePath -> Bool-toCopyRoot srcfp = any (`isSuffixOf` srcfp)-    -- FIXME command line parameters to control how many of these get-    -- copied, trade-off of runtime/bandwidth vs isolation of tests-    [ ".tar"-    , ".xz"-    -- , ".gz"-    , ".7z.exe"-    , "00-index.cache"-    ]+    stripHeadSeparator :: FilePath -> FilePath+    stripHeadSeparator [] = []+    stripHeadSeparator fp@(x:xs) = if isPathSeparator x+                                   then xs+                                   else fp
test/integration/lib/StackTest.hs view
@@ -12,32 +12,54 @@ import System.Process import System.Exit import System.Info (arch, os)+import GHC.Stack (HasCallStack) -run' :: FilePath -> [String] -> IO ExitCode+run' :: HasCallStack => FilePath -> [String] -> IO ExitCode run' cmd args = do     logInfo $ "Running: " ++ cmd ++ " " ++ unwords (map showProcessArgDebug args)     (Nothing, Nothing, Nothing, ph) <- createProcess (proc cmd args)     waitForProcess ph -run :: FilePath -> [String] -> IO ()+run :: HasCallStack => FilePath -> [String] -> IO () run cmd args = do     ec <- run' cmd args     unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec +runShell :: HasCallStack => String -> IO ()+runShell cmd = do+    logInfo $ "Running: " ++ cmd+    (Nothing, Nothing, Nothing, ph) <- createProcess (shell cmd)+    ec <- waitForProcess ph+    unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec++runWithCwd :: HasCallStack => FilePath -> String -> [String] -> IO String+runWithCwd cwdPath cmd args = do+    logInfo $ "Running: " ++ cmd+    let cp = proc cmd args+    (ec, stdoutStr, _) <- readCreateProcessWithExitCode (cp { cwd = Just cwdPath }) ""+    unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec+    return stdoutStr+ stackExe :: IO String stackExe = getEnv "STACK_EXE" -stack' :: [String] -> IO ExitCode+stackSrc :: IO String+stackSrc = getEnv "SRC_DIR"++testDir :: IO String+testDir = getEnv "TEST_DIR"++stack' :: HasCallStack => [String] -> IO ExitCode stack' args = do     stackEnv <- stackExe     run' stackEnv args -stack :: [String] -> IO ()+stack :: HasCallStack => [String] -> IO () stack args = do     ec <- stack' args     unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec -stackErr :: [String] -> IO ()+stackErr :: HasCallStack => [String] -> IO () stackErr args = do     ec <- stack' args     when (ec == ExitSuccess) $ error "stack was supposed to fail, but didn't"@@ -70,7 +92,7 @@ replGetChar :: Repl Char replGetChar = fmap replStdout ask >>= liftIO . hGetChar -runRepl :: FilePath -> [String] -> ReaderT ReplConnection IO () -> IO ExitCode+runRepl :: HasCallStack => FilePath -> [String] -> ReaderT ReplConnection IO () -> IO ExitCode runRepl cmd args actions = do     logInfo $ "Running: " ++ cmd ++ " " ++ unwords (map showProcessArgDebug args)     (Just rStdin, Just rStdout, Just rStderr, ph) <-@@ -84,13 +106,15 @@     hSetBuffering rStderr NoBuffering      _ <- forkIO $ withFile "/tmp/stderr" WriteMode-        $ \err -> forever $ catch (hGetChar rStderr >>= hPutChar err)-                  $ \e -> unless (isEOFError e) $ throw e+        $ \err -> do+            hSetBuffering err NoBuffering+            forever $ catch (hGetChar rStderr >>= hPutChar err)+                    $ \e -> unless (isEOFError e) $ throw e      runReaderT (nextPrompt >> actions) (ReplConnection rStdin rStdout)     waitForProcess ph -repl :: [String] -> Repl () -> IO ()+repl :: HasCallStack => [String] -> Repl () -> IO () repl args action = do     stackExe' <- stackExe     ec <- runRepl stackExe' ("repl":args) action@@ -99,7 +123,7 @@         -- successfully.         -- else error $ "Exited with exit code: " ++ show ec -stackStderr :: [String] -> IO (ExitCode, String)+stackStderr :: HasCallStack => [String] -> IO (ExitCode, String) stackStderr args = do     stackExe' <- stackExe     logInfo $ "Running: " ++ stackExe' ++ " " ++ unwords (map showProcessArgDebug args)@@ -109,7 +133,7 @@  -- | Run stack with arguments and apply a check to the resulting -- stderr output if the process succeeded.-stackCheckStderr :: [String] -> (String -> IO ()) -> IO ()+stackCheckStderr :: HasCallStack => [String] -> (String -> IO ()) -> IO () stackCheckStderr args check = do     (ec, err) <- stackStderr args     if ec /= ExitSuccess@@ -118,32 +142,38 @@  -- | Same as 'stackCheckStderr', but ensures that the Stack process -- fails.-stackErrStderr :: [String] -> (String -> IO ()) -> IO ()+stackErrStderr :: HasCallStack => [String] -> (String -> IO ()) -> IO () stackErrStderr args check = do     (ec, err) <- stackStderr args     if ec == ExitSuccess         then error "Stack process succeeded, but it shouldn't"         else check err -stackStdout :: [String] -> IO (ExitCode, String)-stackStdout args = do-    stackExe' <- stackExe-    logInfo $ "Running: " ++ stackExe' ++ " " ++ unwords (map showProcessArgDebug args)-    (ec, out, err) <- readProcessWithExitCode stackExe' args ""+runEx :: HasCallStack => FilePath -> String -> IO (ExitCode, String, String)+runEx cmd args = runEx' cmd $ words args++runEx' :: HasCallStack => FilePath -> [String] -> IO (ExitCode, String, String)+runEx' cmd args = do+    logInfo $ "Running: " ++ cmd ++ " " ++ unwords (map showProcessArgDebug args)+    (ec, out, err) <- readProcessWithExitCode cmd args ""     putStr out     hPutStr stderr err-    return (ec, out)+    return (ec, out, err)  -- | Run stack with arguments and apply a check to the resulting -- stdout output if the process succeeded.-stackCheckStdout :: [String] -> (String -> IO ()) -> IO ()+--+-- Take care with newlines; if the output includes a newline character that+-- should not be there, use 'Data.List.Extra.trimEnd' to remove it.+stackCheckStdout :: HasCallStack => [String] -> (String -> IO ()) -> IO () stackCheckStdout args check = do-    (ec, out) <- stackStdout args+    stackExe' <- stackExe+    (ec, out, _) <- runEx' stackExe' args     if ec /= ExitSuccess         then error $ "Exited with exit code: " ++ show ec         else check out -doesNotExist :: FilePath -> IO ()+doesNotExist :: HasCallStack => FilePath -> IO () doesNotExist fp = do     logInfo $ "doesNotExist " ++ fp     exists <- doesFileOrDirExist fp@@ -151,7 +181,7 @@       (Right msg) -> error msg       (Left _) -> return () -doesExist :: FilePath -> IO ()+doesExist :: HasCallStack => FilePath -> IO () doesExist fp = do     logInfo $ "doesExist " ++ fp     exists <- doesFileOrDirExist fp@@ -159,7 +189,7 @@       (Right _) -> return ()       (Left _) -> error "No file or directory exists" -doesFileOrDirExist :: FilePath -> IO (Either () String)+doesFileOrDirExist :: HasCallStack => FilePath -> IO (Either () String) doesFileOrDirExist fp = do     isFile <- doesFileExist fp     if isFile@@ -170,12 +200,12 @@                 then return (Right ("Directory exists: " ++ fp))                 else return (Left ()) -copy :: FilePath -> FilePath -> IO ()+copy :: HasCallStack => FilePath -> FilePath -> IO () copy src dest = do     logInfo ("Copy " ++ show src ++ " to " ++ show dest)     System.Directory.copyFile src dest -fileContentsMatch :: FilePath -> FilePath -> IO ()+fileContentsMatch :: HasCallStack => FilePath -> FilePath -> IO () fileContentsMatch f1 f2 = do     doesExist f1     doesExist f2@@ -229,15 +259,38 @@ defaultResolverArg = "--resolver=lts-11.22"  -- | Remove a file and ignore any warnings about missing files.-removeFileIgnore :: FilePath -> IO ()+removeFileIgnore :: HasCallStack => FilePath -> IO () removeFileIgnore fp = removeFile fp `catch` \e ->   if isDoesNotExistError e     then return ()     else throwIO e --- | Remove a directory tree and ignore any warnings about missing files.-removeDirectoryRecursiveIgnore :: FilePath -> IO ()-removeDirectoryRecursiveIgnore fp = removeDirectoryRecursive fp `catch` \e ->+-- | Remove a directory and ignore any warnings about missing files.+removeDirIgnore :: HasCallStack => FilePath -> IO ()+removeDirIgnore fp = removeDirectoryRecursive fp `catch` \e ->   if isDoesNotExistError e     then return ()     else throwIO e++-- | Changes working directory to Stack source directory+withSourceDirectory :: HasCallStack => IO () -> IO ()+withSourceDirectory action = do+  dir <- stackSrc+  currentDirectory <- getCurrentDirectory+  let enterDir = setCurrentDirectory dir+      exitDir = setCurrentDirectory currentDirectory+  bracket_ enterDir exitDir action++-- | Mark a test as superslow, only to be run when explicitly requested.+superslow :: HasCallStack => IO () -> IO ()+superslow inner = do+  mres <- lookupEnv "STACK_TEST_SPEED"+  case mres of+    Just "NORMAL" -> logInfo "Skipping superslow test"+    Just "SUPERSLOW" -> do+      logInfo "Running superslow test, hold on to your butts"+      inner+    Nothing -> do+      logInfo "No STACK_TEST_SPEED specified. Executing superslow test, hold on to your butts"+      inner+    Just x -> error $ "Invalid value for STACK_TEST_SPEED env var: " ++ show x