stack 1.1.0 → 1.1.2
raw patch · 69 files changed
+2334/−1591 lines, 69 filesdep +base-compatdep +generic-derivingdep +hitdep ~QuickCheckdep ~binarydep ~conduit
Dependencies added: base-compat, generic-deriving, hit, monad-unlift, regex-applicative-text, tls
Dependency ranges changed: QuickCheck, binary, conduit, either, extra, hpack, http-conduit, persistent, persistent-sqlite, process, resourcet, split, stack, template-haskell, time, transformers, zip-archive
Files
- CONTRIBUTING.md +1/−1
- ChangeLog.md +72/−2
- doc/CONTRIBUTING.md +1/−1
- doc/ChangeLog.md +72/−2
- doc/GUIDE.md +13/−4
- doc/MAINTAINER_GUIDE.md +88/−31
- doc/README.md +1/−1
- doc/docker_integration.md +4/−4
- doc/faq.md +1/−1
- doc/install_and_upgrade.md +14/−0
- src/Data/Aeson/Extended.hs +13/−12
- src/Data/Monoid/Extra.hs +12/−0
- src/Network/HTTP/Download.hs +11/−4
- src/Network/HTTP/Download/Verified.hs +44/−38
- src/Options/Applicative/Builder/Extra.hs +15/−6
- src/Stack/Build.hs +13/−10
- src/Stack/Build/Cache.hs +23/−22
- src/Stack/Build/ConstructPlan.hs +18/−20
- src/Stack/Build/Execute.hs +31/−23
- src/Stack/Build/Haddock.hs +13/−8
- src/Stack/Build/Source.hs +174/−126
- src/Stack/BuildPlan.hs +256/−84
- src/Stack/Config.hs +120/−101
- src/Stack/Config/Build.hs +27/−20
- src/Stack/Config/Docker.hs +16/−14
- src/Stack/Config/Nix.hs +21/−9
- src/Stack/Config/Urls.hs +4/−4
- src/Stack/ConfigCmd.hs +2/−3
- src/Stack/Constants.hs +10/−10
- src/Stack/Coverage.hs +14/−14
- src/Stack/Docker.hs +3/−3
- src/Stack/Dot.hs +13/−15
- src/Stack/Exec.hs +6/−3
- src/Stack/Fetch.hs +71/−27
- src/Stack/GhcPkg.hs +5/−5
- src/Stack/Ghci.hs +35/−10
- src/Stack/Ide.hs +2/−2
- src/Stack/Init.hs +19/−15
- src/Stack/New.hs +11/−10
- src/Stack/Options.hs +146/−114
- src/Stack/Package.hs +150/−139
- src/Stack/PackageDump.hs +3/−3
- src/Stack/PackageIndex.hs +3/−3
- src/Stack/SDist.hs +7/−8
- src/Stack/Setup.hs +12/−9
- src/Stack/Setup/Installed.hs +10/−10
- src/Stack/Sig/GPG.hs +29/−10
- src/Stack/Sig/Sign.hs +6/−7
- src/Stack/Solver.hs +61/−70
- src/Stack/Types/Build.hs +7/−27
- src/Stack/Types/BuildPlan.hs +42/−0
- src/Stack/Types/Config.hs +293/−219
- src/Stack/Types/Config/Build.hs +93/−98
- src/Stack/Types/Docker.hs +39/−71
- src/Stack/Types/Image.hs +6/−7
- src/Stack/Types/Internal.hs +9/−8
- src/Stack/Types/Nix.hs +20/−33
- src/Stack/Types/Package.hs +7/−4
- src/Stack/Types/Sig.hs +2/−4
- src/Stack/Types/StackT.hs +4/−4
- src/Stack/Types/Urls.hs +11/−11
- src/Stack/Types/Version.hs +11/−0
- src/Stack/Upgrade.hs +14/−17
- src/main/Main.hs +48/−30
- src/test/Network/HTTP/Download/VerifiedSpec.hs +4/−2
- src/test/Stack/BuildPlanSpec.hs +2/−0
- stack.cabal +22/−15
- stack.yaml +3/−2
- test/integration/lib/StackTest.hs +1/−1
CONTRIBUTING.md view
@@ -2,7 +2,7 @@ ## Bug Reports -Before reporting a bug, please ensure that you are using the latest release (currently stack-1.1.0). See the [upgrade instructions](http://docs.haskellstack.org/en/stable/install_and_upgrade/#upgrade) to upgrade.+Before reporting a bug, please ensure that you are using the latest release (currently stack-1.1.2). See the [upgrade instructions](http://docs.haskellstack.org/en/stable/install_and_upgrade/#upgrade) to upgrade. When reporting a bug, please write in the following format:
ChangeLog.md view
@@ -1,9 +1,79 @@ # Changelog -## v1.1.0+## 1.1.2 Release notes: +* Official FreeBSD binaries are+ [now available](http://docs.haskellstack.org/en/stable/install_and_upgrade/#freebsd)+ [#1253](https://github.com/commercialhaskell/stack/issues/1253).++Major changes:++* Extensible custom snapshots implemented. These allow you to define snapshots+which extend other snapshots. See+[#863](https://github.com/commercialhaskell/stack/issues/863). Local file custom+snapshots can now be safely updated without changing their name. Remote custom+snapshots should still be treated as immutable.++Behavior changes:++* `stack path --compiler` was added in the last release, to yield a path to the+ compiler. Unfortunately, `--compiler` is a global option that is useful to use+ with `stack path`. The same functionality is now provided by `stack path+ --compiler-exe`. See+ [#2123](https://github.com/commercialhaskell/stack/issues/2123)+* For packages specified in terms of a git or hg repo, the hash used in the+ location has changed. This means that existing downloads from older stack+ versions won't be used. This is a side-effect of the fix to+ [#2133](https://github.com/commercialhaskell/stack/issues/2133)+* `stack upgrade` no longer pays attention to local stack.yaml files, just the+ global config and CLI options.+ [#1392](https://github.com/commercialhaskell/stack/issues/1392)+* `stack ghci` now uses `:add` instead of `:load`, making it potentially work+ better with user scripts. See+ [#1888](https://github.com/commercialhaskell/stack/issues/1888)++Other enhancements:++* Grab Cabal files via Git SHA to avoid regressions from Hackage revisions+ [#2070](https://github.com/commercialhaskell/stack/pull/2070)+* Custom snapshots now support `ghc-options`.+* Package git repos are now re-used rather than re-cloned. See+ [#1620](https://github.com/commercialhaskell/stack/issues/1620)+* `DESTDIR` is filtered from environment when installing GHC. See+ [#1460](https://github.com/commercialhaskell/stack/issues/1460)+* `stack haddock` now supports `--hadock-arguments`. See+ [#2144](https://github.com/commercialhaskell/stack/issues/2144)+* Signing: warn if GPG_TTY is not set as per `man gpg-agent`++Bug fixes:++* Now ignore project config when doing `stack init` or `stack new`. See+ [#2110](https://github.com/commercialhaskell/stack/issues/2110)+* Packages specified by git repo can now have submodules. See+ [#2133](https://github.com/commercialhaskell/stack/issues/2133)+* Fix of hackage index fetch retry. See re-opening of+ [#1418](https://github.com/commercialhaskell/stack/issues/1418#issuecomment-217633843)+* HPack now picks up changes to filesystem other than package.yaml. See+ [#2051](https://github.com/commercialhaskell/stack/issues/2051)+* "stack solver" no longer suggests --omit-packages. See+ [#2031](https://github.com/commercialhaskell/stack/issues/2031)+* Fixed an issue with building Cabal's Setup.hs. See+ [#1356](https://github.com/commercialhaskell/stack/issues/1356)+* Package dirtiness now pays attention to deleted files. See+ [#1841](https://github.com/commercialhaskell/stack/issues/1841)+* `stack ghci` now uses `extra-lib-dirs` and `extra-include-dirs`. See+ [#1656](https://github.com/commercialhaskell/stack/issues/1656)+* Relative paths outside of source dir added via `qAddDependentFile` are now+ checked for dirtiness. See+ [#1982](https://github.com/commercialhaskell/stack/issues/1982)+* Signing: always use `--with-fingerprints`++## 1.1.0++Release notes:+ * Added Ubuntu 16.04 LTS (xenial) Apt repo. * No longer uploading new versions to Fedora 21 repo. @@ -33,7 +103,7 @@ * GPG signing of packages while uploading to Hackage is now the default. Use `upload --no-signature` if you would rather not contribute your package signature. If you don't yet have a GPG keyset, read this- [blog post on GPG keys](https://fpcomplete.com/blog/2016/04/stack-security-gnupg-keys)+ [blog post on GPG keys](https://fpcomplete.com/blog/2016/05/stack-security-gnupg-keys). We can add a stack.yaml config setting to disable signing if some people desire it. We hope that people will sign. Later we will be adding GPG signature verification options.
doc/CONTRIBUTING.md view
@@ -2,7 +2,7 @@ ## Bug Reports -Before reporting a bug, please ensure that you are using the latest release (currently stack-1.1.0). See the [upgrade instructions](http://docs.haskellstack.org/en/stable/install_and_upgrade/#upgrade) to upgrade.+Before reporting a bug, please ensure that you are using the latest release (currently stack-1.1.2). See the [upgrade instructions](http://docs.haskellstack.org/en/stable/install_and_upgrade/#upgrade) to upgrade. When reporting a bug, please write in the following format:
doc/ChangeLog.md view
@@ -1,9 +1,79 @@ # Changelog -## v1.1.0+## 1.1.2 Release notes: +* Official FreeBSD binaries are+ [now available](http://docs.haskellstack.org/en/stable/install_and_upgrade/#freebsd)+ [#1253](https://github.com/commercialhaskell/stack/issues/1253).++Major changes:++* Extensible custom snapshots implemented. These allow you to define snapshots+which extend other snapshots. See+[#863](https://github.com/commercialhaskell/stack/issues/863). Local file custom+snapshots can now be safely updated without changing their name. Remote custom+snapshots should still be treated as immutable.++Behavior changes:++* `stack path --compiler` was added in the last release, to yield a path to the+ compiler. Unfortunately, `--compiler` is a global option that is useful to use+ with `stack path`. The same functionality is now provided by `stack path+ --compiler-exe`. See+ [#2123](https://github.com/commercialhaskell/stack/issues/2123)+* For packages specified in terms of a git or hg repo, the hash used in the+ location has changed. This means that existing downloads from older stack+ versions won't be used. This is a side-effect of the fix to+ [#2133](https://github.com/commercialhaskell/stack/issues/2133)+* `stack upgrade` no longer pays attention to local stack.yaml files, just the+ global config and CLI options.+ [#1392](https://github.com/commercialhaskell/stack/issues/1392)+* `stack ghci` now uses `:add` instead of `:load`, making it potentially work+ better with user scripts. See+ [#1888](https://github.com/commercialhaskell/stack/issues/1888)++Other enhancements:++* Grab Cabal files via Git SHA to avoid regressions from Hackage revisions+ [#2070](https://github.com/commercialhaskell/stack/pull/2070)+* Custom snapshots now support `ghc-options`.+* Package git repos are now re-used rather than re-cloned. See+ [#1620](https://github.com/commercialhaskell/stack/issues/1620)+* `DESTDIR` is filtered from environment when installing GHC. See+ [#1460](https://github.com/commercialhaskell/stack/issues/1460)+* `stack haddock` now supports `--hadock-arguments`. See+ [#2144](https://github.com/commercialhaskell/stack/issues/2144)+* Signing: warn if GPG_TTY is not set as per `man gpg-agent`++Bug fixes:++* Now ignore project config when doing `stack init` or `stack new`. See+ [#2110](https://github.com/commercialhaskell/stack/issues/2110)+* Packages specified by git repo can now have submodules. See+ [#2133](https://github.com/commercialhaskell/stack/issues/2133)+* Fix of hackage index fetch retry. See re-opening of+ [#1418](https://github.com/commercialhaskell/stack/issues/1418#issuecomment-217633843)+* HPack now picks up changes to filesystem other than package.yaml. See+ [#2051](https://github.com/commercialhaskell/stack/issues/2051)+* "stack solver" no longer suggests --omit-packages. See+ [#2031](https://github.com/commercialhaskell/stack/issues/2031)+* Fixed an issue with building Cabal's Setup.hs. See+ [#1356](https://github.com/commercialhaskell/stack/issues/1356)+* Package dirtiness now pays attention to deleted files. See+ [#1841](https://github.com/commercialhaskell/stack/issues/1841)+* `stack ghci` now uses `extra-lib-dirs` and `extra-include-dirs`. See+ [#1656](https://github.com/commercialhaskell/stack/issues/1656)+* Relative paths outside of source dir added via `qAddDependentFile` are now+ checked for dirtiness. See+ [#1982](https://github.com/commercialhaskell/stack/issues/1982)+* Signing: always use `--with-fingerprints`++## 1.1.0++Release notes:+ * Added Ubuntu 16.04 LTS (xenial) Apt repo. * No longer uploading new versions to Fedora 21 repo. @@ -33,7 +103,7 @@ * GPG signing of packages while uploading to Hackage is now the default. Use `upload --no-signature` if you would rather not contribute your package signature. If you don't yet have a GPG keyset, read this- [blog post on GPG keys](https://fpcomplete.com/blog/2016/04/stack-security-gnupg-keys)+ [blog post on GPG keys](https://fpcomplete.com/blog/2016/05/stack-security-gnupg-keys). We can add a stack.yaml config setting to disable signing if some people desire it. We hope that people will sign. Later we will be adding GPG signature verification options.
doc/GUIDE.md view
@@ -86,10 +86,19 @@ ### stack new -We'll start off with the `stack new` command to create a new-*project*. We'll call our project `helloworld`, and we'll use the-`new-template` project template:+We'll start off with the `stack new` command to create a new *project*, that+will contain a Haskell *package* of the same name. So let's pick a valid+package name first: +> A package is identified by a globally-unique package name, which consists+of one or more alphanumeric words separated by hyphens. To avoid ambiguity,+each of these words should contain at least one letter.++(From the [Cabal users guide](https://www.haskell.org/cabal/users-guide/developing-packages.html#developing-packages))++We'll call our project `helloworld`, and we'll use the `new-template` project+template:+ ``` michael@d30748af6d3d:~$ stack new helloworld new-template ```@@ -516,7 +525,7 @@ * A full list of all packages available in this snapshot * The ability to perform a Hoogle search on the packages in this snapshot * A [list of all modules](https://www.stackage.org/lts-3.2/docs) in a snapshot,- which an be useful when trying to determine which package to add to your+ which can be useful when trying to determine which package to add to your .cabal file You can also see a [list of all available
doc/MAINTAINER_GUIDE.md view
@@ -1,21 +1,9 @@ # Maintainer guide -## Next release:--* Check that GPG signature for- [Releases](https://s3.amazonaws.com/download.fpcomplete.com/debian/dists/jessie/Release)- uses SHA512, and close- [#1943](https://github.com/commercialhaskell/stack/issues/1934)-* Integrate FreeBSD binaries and packages- [#1253](https://github.com/commercialhaskell/stack/issues/1253#issuecomment-185993240)--## Pre-release checks--The following should be tested minimally before a release is considered good-to go:+## Pre-release steps * Ensure `release` and `stable` branches merged to `master`-* Integration tests pass on a representative Windows, Mac OS X, and Linux (Linux+* Ensure integration tests pass on a representative Windows, Mac OS X, and Linux (Linux is handled by Jenkins automatically): `stack install --pedantic && stack test --pedantic --flag stack:integration-tests` . The actual release script will perform a more thorough test for every platform/variant prior to uploading, so@@ -38,7 +26,7 @@ still needed * In RC branch: * Update the ChangeLog- ([this comparison](https://github.com/commercialhaskell/stack/compare/release...master)+ ([this comparison](https://github.com/commercialhaskell/stack/compare/stable...master) is handy): * Check for any important changes that missed getting an entry in Changelog * Check for any entries that snuck into the previous version's changes@@ -50,11 +38,12 @@ * Look for any links to "latest" documentation, replace with version tag * Ensure all documentation pages listed in `mkdocs.yaml` * Check that any new Linux distribution versions added to- `etc/scripts/release.hs` and `etc/scripts/vagrant-releases.sh`.+ `etc/scripts/release.hs` and `etc/scripts/vagrant-releases.sh` * [Ubuntu](https://wiki.ubuntu.com/Releases) * [Debian](https://www.debian.org/releases/) (keep at least latest two) * [CentOS](https://wiki.centos.org/Download) * [Fedora](https://fedoraproject.org/wiki/Releases)+ * Check for new FreeBSD release * Check that no new entries need to be added to [releases.yaml](https://github.com/fpco/stackage-content/blob/master/stack/releases.yaml), [install_and_upgrade.md](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md),@@ -95,17 +84,12 @@ * Release Windows installers. See [stack-installer README](https://github.com/borsboom/stack-installer#readme) -* Push signed Git tag, matching Github release tag name, e.g.: `git tag -u- 0x575159689BEFB442 vX.Y.Z && git push origin vX.Y.Z`--* Reset the `release` branch to the released commit, e.g.: `git checkout release- && git merge --ff-only vX.Y.Z && git push origin release`--* Update the `stable` branch similarly+* Publish Github release -* Delete the RC branch (locally and on origin)+* Upload package to Hackage: `stack upload . --pvp-bounds=both` -* Publish Github release+* On a machine with Vagrant installed:+ * Run `etc/scripts/vagrant-distros.sh` * Edit [stack-setup-2.yaml](https://github.com/fpco/stackage-content/blob/master/stack/stack-setup-2.yaml),@@ -115,18 +99,23 @@ [readthedocs.org](https://readthedocs.org/projects/stack/versions/), and ensure that stable documentation has updated -* Upload package to Hackage: `stack upload . --pvp-bounds=both`--* On a machine with Vagrant installed:- * Run `etc/scripts/vagrant-distros.sh`- * Submit a PR for the- [haskell-stack Homebrew formula](https://github.com/Homebrew/homebrew/blob/master/Library/Formula/haskell-stack.rb)+ [haskell-stack Homebrew formula](https://github.com/Homebrew/homebrew-core/blob/master/Formula/haskell-stack.rb) * Be sure to update the SHA sum * The commit message should just be `haskell-stack <VERSION>` * [Flag the Arch Linux package as out-of-date](https://www.archlinux.org/packages/community/x86_64/stack/flag/) +* Push signed Git tag, matching Github release tag name, e.g.: `git tag -u+ 0x575159689BEFB442 vX.Y.Z && git push origin vX.Y.Z`++* Reset the `release` branch to the released commit, e.g.: `git checkout release+ && git merge --ff-only vX.Y.Z && git push origin release`++* Update the `stable` branch similarly++* Delete the RC branch (locally and on origin)+ * Upload haddocks to Hackage: `etc/scripts/upload-haddocks.sh` * Merge any changes made in the RC/release/stable branches to master.@@ -136,3 +125,71 @@ * Keep an eye on the [Hackage matrix builder](http://matrix.hackage.haskell.org/package/stack)++## Setting up a Windows VM for releases++These instructions are a bit rough, but has the steps to get the Windows machine+set up.++ 1. Download VM image:+ https://developer.microsoft.com/en-us/microsoft-edge/tools/vms/mac/++ 2. Launch the VM using Virtualbox and the image downloaded++ 3. Adjust settings:+ * Number of CPUs: match the host+ * Memory: at least 3 GB+ * Video RAM: the minimum recommended by Virtualbox+ * Enable 3D and 2D accelerated mode+ * Enabled shared clipboard (both directions)++ 4. Install the VMware guest additions, and reboot++ 5. Configure a shared folder for your home directory on the host, and mount it on Z:++ 6. Install Windows SDK (for signtool):+ http://microsoft.com/en-us/download/confirmation.aspx?id=8279++ 7. Install msysgit: https://msysgit.github.io/++ 8. Install nsis-2.46.5-Unicode-setup.exe from http://www.scratchpaper.com/++ 9: Install Stack using the Windows 64-bit installer++10. Visit https://hackage.haskell.org/ in Edge to ensure system has correct CA+ certificates++11. Get the object code certificate from+ [password-store](https://github.com/fpco/password-store), in+ `certificates/code_signing/fpcomplete_corporation_startssl_2015-09-22.pfx`.+ Double click it in explorer and import it++12. Run in command prompt:++ md C:\p+ md C:\p\tmp+ cd \p+ md c:\tmp++13. Create `C:\p\env.bat`:++ SET STACK_ROOT=C:\p\.sr+ SET TEMP=C:\p\tmp+ SET TMP=C:\p\tmp+ SET PATH=C:\Users\IEUser\AppData\Roaming\local\bin;"c:\Program Files\Git\usr\bin";"C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin";%PATH%++14. Run `C:\p\env.bat` (do this every time you open a new command prompt)++15. Import the `dev@fpcomplete.com` (0x575159689BEFB442) GPG secret key++16. Run in command prompt (adjust the `user.email` and `user.name` settings):++ stack setup+ stack install cabal-install+ md %HOMEPATH%\.ssh+ copy z:\.ssh\id_rsa %HOMEPATH%\.ssh+ git config --global user.email manny@fpcomplete.com+ git config --global user.name "Emanuel Borsboom"+ git config --global push.default simple+ git clone git@github.com:commercialhaskell/stack.git+ git clone git@github.com:borsboom/stack-installer.git
doc/README.md view
@@ -27,7 +27,7 @@ * [Arch Linux](install_and_upgrade.md#arch-linux) * [NixOS](install_and_upgrade.md#nixos) * [Linux (general)](install_and_upgrade.md#linux)-* [FreeBSD (unofficial)](install_and_upgrade.md#freebsd)+* [FreeBSD](install_and_upgrade.md#freebsd) [Upgrade instructions](install_and_upgrade.md#upgrade)
doc/docker_integration.md view
@@ -145,17 +145,17 @@ # If true, the container will be run "detached" (in the background). Refer # to the Docker users guide for information about how to manage containers. # This option would rarely make sense in the configuration file, but can be- # useful on the command-line. When true, implies `persistent`.`+ # useful on the command-line. When true, implies `persist`.` detach: false # If true, the container will not be deleted after it terminates. Refer to # the Docker users guide for information about how to manage containers. This # option would rarely make sense in the configuration file, but can be- # useful on the command-line. `detach` implies `persistent`.- persistent: false+ # useful on the command-line. `detach` implies `persist`.+ persist: false # What to name the Docker container. Only useful with `detach` or- # `persistent` true. (default none)+ # `persist` true. (default none) container-name: "example-name" # Additional arguments to pass to `docker run`. (default none)
doc/faq.md view
@@ -93,7 +93,7 @@ However, virtually all `cabal` commands have an equivalent in stack, so this should not be necessary. In particular, `cabal` users may be accustomed to the `cabal run` command. In stack: ``` $ stack build && stack exec <program-name>-````+``` Or, if you want to install the binaries in a shared location: ``` $ stack install
doc/install_and_upgrade.md view
@@ -271,6 +271,20 @@ ## FreeBSD +(only 64-bit currently available, tested on FreeBSD 10.3-RELEASE)++* Install required dependencies:++ pkg install devel/gmake perl5 lang/gcc misc/compat8x misc/compat9x converters/libiconv ca_root_nss++* Download the latest release:++ * [FreeBSD 64-bit](https://www.stackage.org/stack/freebsd-x86_64)++* Extract the archive and place `stack` somewhere on your `$PATH` (see [Path section below](#path))++* Now you can run `stack` from the terminal.+ An unofficial package repository for FreeBSD 10 (amd64 only) and install instructions are available at [http://stack-pkg.applicative.tech](http://stack-pkg.applicative.tech/). The repository is not official and as such might lag behind new releases. See [issue #1253](https://github.com/commercialhaskell/stack/issues/1253)
src/Data/Aeson/Extended.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, TemplateHaskell, TupleSections #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} -- | Extensions to Aeson parsing of objects. module Data.Aeson.Extended (@@ -37,6 +41,8 @@ import qualified Data.Text as T import Data.Traversable import qualified Data.Traversable as Traversable+import GHC.Generics (Generic)+import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Prelude -- Fix redundant import warnings -- | Extends @.:@ warning to include field name.@@ -143,24 +149,19 @@ data WarningParserMonoid = WarningParserMonoid { wpmExpectedFields :: !(Set Text) , wpmWarnings :: [JSONWarning]- }+ } deriving Generic instance Monoid WarningParserMonoid where- mempty = WarningParserMonoid Set.empty []- mappend a b =- WarningParserMonoid- { wpmExpectedFields = Set.union- (wpmExpectedFields a)- (wpmExpectedFields b)- , wpmWarnings = wpmWarnings a ++ wpmWarnings b- }+ mempty = memptydefault+ mappend = mappenddefault -- Parsed JSON value with its warnings data WithJSONWarnings a = WithJSONWarnings a [JSONWarning]+ deriving Generic instance Functor WithJSONWarnings where fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w instance Monoid a => Monoid (WithJSONWarnings a) where- mempty = noJSONWarnings mempty- mappend (WithJSONWarnings a aw) (WithJSONWarnings b bw) = WithJSONWarnings (mappend a b) (mappend aw bw)+ mempty = memptydefault+ mappend = mappenddefault -- | Warning output from 'WarningParser'. data JSONWarning = JSONUnrecognizedFields String [Text]
+ src/Data/Monoid/Extra.hs view
@@ -0,0 +1,12 @@+-- | Extra Monoid utilities.++module Data.Monoid.Extra+ ( fromFirst+ , module Data.Monoid+ ) where++import Data.Maybe+import Data.Monoid++fromFirst :: a -> First a -> a+fromFirst x = fromMaybe x . getFirst
src/Network/HTTP/Download.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} module Network.HTTP.Download ( verifiedDownload , DownloadRequest(..)@@ -26,8 +27,9 @@ import Control.Exception (Exception) import Control.Exception.Enclosed (handleIO) import Control.Monad (void)-import Control.Monad.Catch (MonadThrow, MonadMask, throwM)+import Control.Monad.Catch (MonadMask, throwM) import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (MonadLogger, logDebug) import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) import Data.Aeson.Extended (FromJSON, parseJSON)@@ -40,7 +42,11 @@ import Data.Conduit.Binary (sinkHandle, sourceHandle) import qualified Data.Conduit.Binary as CB import Data.Foldable (forM_)+import Data.Monoid ((<>))+import Data.Text.Encoding.Error (lenientDecode)+import Data.Text.Encoding (decodeUtf8With) import Data.Typeable (Typeable)+import Network.HTTP.Client (path) import Network.HTTP.Client.Conduit (HasHttpManager, Manager, Request, Response, checkStatus, getHttpManager, parseUrl,@@ -64,7 +70,7 @@ -- appropriate destination. -- -- Throws an exception if things go wrong-download :: (MonadReader env m, HasHttpManager env, MonadIO m)+download :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m) => Request -> Path Abs File -- ^ destination -> m Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?@@ -81,11 +87,12 @@ -- | Same as 'download', but will download a file a second time if it is already present. -- -- Returns 'True' if the file was downloaded, 'False' otherwise-redownload :: (MonadReader env m, HasHttpManager env, MonadIO m)+redownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m) => Request -> Path Abs File -- ^ destination -> m Bool redownload req0 dest = do+ $logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req0) let destFilePath = toFilePath dest etagFilePath = destFilePath <.> "etag" @@ -129,7 +136,7 @@ | otherwise -> throwM $ RedownloadFailed req2 dest $ void res -- | Download a JSON value and parse it using a 'FromJSON' instance.-downloadJSON :: (FromJSON a, MonadReader env m, HasHttpManager env, MonadIO m, MonadThrow m, MonadMask m)+downloadJSON :: (FromJSON a, MonadReader env m, HasHttpManager env, MonadIO m, MonadMask m) => Request -> m a downloadJSON req = do
src/Network/HTTP/Download/Verified.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} module Network.HTTP.Download.Verified ( verifiedDownload , recoveringHttp@@ -19,38 +20,41 @@ , 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 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-import Control.Monad.IO.Class-import Control.Monad.Reader-import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay)-import Control.Applicative+import Control.Applicative+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger (logDebug, MonadLogger)+import Control.Monad.Reader+import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay) import "cryptohash" Crypto.Hash-import Crypto.Hash.Conduit (sinkHash)-import Data.ByteString (ByteString)-import Data.ByteString.Char8 (readInteger)-import Data.Conduit-import Data.Conduit.Binary (sourceHandle, sinkHandle)-import Data.Foldable (traverse_,for_)-import Data.Monoid-import Data.String-import Data.Typeable (Typeable)-import GHC.IO.Exception (IOException(..),IOErrorType(..))-import Network.HTTP.Client.Conduit-import Network.HTTP.Types.Header (hContentLength, hContentMD5)-import Path-import Prelude -- Fix AMP warning-import System.FilePath((<.>))-import System.Directory-import System.IO+import Crypto.Hash.Conduit (sinkHash)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 (readInteger)+import Data.Conduit+import Data.Conduit.Binary (sourceHandle, sinkHandle)+import Data.Foldable (traverse_,for_)+import Data.Monoid+import Data.String+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Typeable (Typeable)+import GHC.IO.Exception (IOException(..),IOErrorType(..))+import Network.HTTP.Client.Conduit+import Network.HTTP.Types.Header (hContentLength, hContentMD5)+import Path+import Prelude -- Fix AMP warning+import System.Directory+import System.FilePath ((<.>))+import System.IO -- | A request together with some checks to perform. data DownloadRequest = DownloadRequest@@ -215,7 +219,7 @@ -- Throws VerifiedDownloadException. -- Throws IOExceptions related to file system operations. -- Throws HttpException.-verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m)+verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m) => DownloadRequest -> Path Abs File -- ^ destination -> (Maybe Integer -> Sink ByteString (ReaderT env IO) ()) -- ^ custom hook to observe progress@@ -223,13 +227,15 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do let req = drRequest env <- ask- liftIO $ whenM' getShouldDownload $ do- createDirectoryIfMissing True dir- withBinaryFile fptmp WriteMode $ \h ->- recoveringHttp drRetryPolicy $- flip runReaderT env $- withResponse req (go h)- renameFile fptmp fp+ whenM' (liftIO getShouldDownload) $ do+ $logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req)+ liftIO $ do+ createDirectoryIfMissing True dir+ withBinaryFile fptmp WriteMode $ \h ->+ recoveringHttp drRetryPolicy $+ flip runReaderT env $+ withResponse req (go h)+ renameFile fptmp fp where whenM' mp m = do p <- mp
src/Options/Applicative/Builder/Extra.hs view
@@ -4,15 +4,18 @@ (boolFlags ,boolFlagsNoDefault ,maybeBoolFlags+ ,firstBoolFlags ,enableDisableFlags ,enableDisableFlagsNoDefault ,extraHelpOption ,execExtraHelp ,textOption- ,textArgument)- where+ ,textArgument+ ,optionalFirst+ ) where import Control.Monad (when)+import Data.Monoid import Options.Applicative import Options.Applicative.Types (readerAsk) import System.Environment (withArgs)@@ -42,9 +45,12 @@ -> Parser (Maybe Bool) maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False) +-- | 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+ -- | Enable/disable flags for any type.-enableDisableFlags :: (Eq a)- => a -- ^ Default value+enableDisableFlags :: a -- ^ Default value -> a -- ^ Enabled value -> a -- ^ Disabled value -> String -- ^ Name@@ -56,8 +62,7 @@ pure defaultValue -- | Enable/disable flags for any type, without a default (to allow chaining with '<|>')-enableDisableFlagsNoDefault :: (Eq a)- => a -- ^ Enabled value+enableDisableFlagsNoDefault :: a -- ^ Enabled value -> a -- ^ Disabled value -> String -- ^ Name -> String -- ^ Help suffix@@ -127,3 +132,7 @@ -- | 'argument', specialized to 'Text'. textArgument :: Mod ArgumentFields Text -> Parser Text textArgument = argument (T.pack <$> readerAsk)++-- | Like 'optional', but returning a 'First'.+optionalFirst :: Alternative f => f a -> f (First a)+optionalFirst = fmap First . optional
src/Stack/Build.hs view
@@ -22,11 +22,12 @@ import Control.Exception (Exception) import Control.Monad-import Control.Monad.Catch (MonadCatch, MonadMask)+import Control.Monad.Catch (MonadMask, MonadMask) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Resource+import Control.Monad.Trans.Unlift (MonadBaseUnlift) import Data.Aeson (Value (Object, Array), (.=), object) import Data.Function import qualified Data.HashMap.Strict as HM@@ -68,7 +69,7 @@ import qualified Control.Monad.Catch as Catch #endif -type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)+type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseUnlift IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) -- | Build. --@@ -267,39 +268,40 @@ withLoadPackage :: ( MonadIO m , HasHttpManager env , MonadReader env m- , MonadBaseControl IO m- , MonadCatch m+ , MonadBaseUnlift IO m+ , MonadMask m , MonadLogger m , HasEnvConfig env) => EnvOverride- -> ((PackageName -> Version -> Map FlagName Bool -> IO Package) -> m a)+ -> ((PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -> m a) -> m a withLoadPackage menv inner = do econfig <- asks getEnvConfig withCabalLoader menv $ \cabalLoader ->- inner $ \name version flags -> do+ inner $ \name version flags ghcOptions -> do bs <- cabalLoader $ PackageIdentifier name version -- Intentionally ignore warnings, as it's not really -- appropriate to print a bunch of warnings out while -- resolving the package index.- (_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags) bs+ (_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags ghcOptions) bs return pkg where -- | Package config to be used for dependencies- depPackageConfig :: EnvConfig -> Map FlagName Bool -> PackageConfig- depPackageConfig econfig flags = PackageConfig+ depPackageConfig :: EnvConfig -> Map FlagName Bool -> [Text] -> PackageConfig+ depPackageConfig econfig flags ghcOptions = PackageConfig { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False , packageConfigFlags = flags+ , packageConfigGhcOptions = ghcOptions , packageConfigCompilerVersion = envConfigCompilerVersion econfig , packageConfigPlatform = configPlatform (getConfig econfig) } -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738-fixCodePage :: M env m => m a -> m a #ifdef WINDOWS+fixCodePage :: M env m => m a -> m a fixCodePage inner = do mcp <- asks $ configModifyCodePage . getConfig ec <- asks getEnvConfig@@ -341,6 +343,7 @@ , " codepage to UTF-8 (65001) to ensure correct output from GHC" ] #else+fixCodePage :: a -> a fixCodePage = id #endif
src/Stack/Build/Cache.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE OverloadedStrings #-} -- | Cache information about previous builds module Stack.Build.Cache ( tryGetBuildCache@@ -28,7 +29,7 @@ import Control.Exception.Enclosed (handleIO) import Control.Monad.Catch (MonadThrow, MonadCatch) import Control.Monad.IO.Class-import Control.Monad.Logger (MonadLogger)+import Control.Monad.Logger (MonadLogger, logDebug) import Control.Monad.Reader import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.Binary as Binary (encode)@@ -37,6 +38,7 @@ import qualified Data.ByteString.Base16 as B16 import Data.Map (Map) import Data.Maybe (fromMaybe, mapMaybe)+import Data.Monoid ((<>)) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text)@@ -96,17 +98,17 @@ instance NFData BuildCache -- | Try to read the dirtiness cache for the given package directory.-tryGetBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)+tryGetBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) => Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo)) tryGetBuildCache = liftM (fmap buildCacheTimes) . tryGetCache buildCacheFile -- | Try to read the dirtiness cache for the given package directory.-tryGetConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)+tryGetConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) => Path Abs Dir -> m (Maybe ConfigCache) tryGetConfigCache = tryGetCache configCacheFile -- | Try to read the mod time of the cabal file from the last build-tryGetCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)+tryGetCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) => Path Abs Dir -> m (Maybe ModTime) tryGetCabalMod = tryGetCache configCabalMod @@ -120,7 +122,7 @@ decodeFileOrFailDeep fp -- | Write the dirtiness cache for this package's files.-writeBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)+writeBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) => Path Abs Dir -> Map FilePath FileCacheInfo -> m () writeBuildCache dir times = writeCache@@ -131,21 +133,21 @@ } -- | Write the dirtiness cache for this package's configuration.-writeConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)+writeConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) => Path Abs Dir -> ConfigCache -> m () writeConfigCache dir = writeCache dir configCacheFile -- | See 'tryGetCabalMod'-writeCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)+writeCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) => Path Abs Dir -> ModTime -> m () writeCabalMod dir = writeCache dir configCabalMod -- | Delete the caches for the project.-deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadCatch m, HasEnvConfig env)+deleteCaches :: (MonadIO m, MonadReader env m, MonadCatch m, HasEnvConfig env) => Path Abs Dir -> m () deleteCaches dir = do {- FIXME confirm that this is acceptable to remove@@ -195,7 +197,7 @@ taggedEncodeFile file cache -- | Mark a test suite as having succeeded-setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+setTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) => Path Abs Dir -> m () setTestSuccess dir =@@ -205,7 +207,7 @@ True -- | Mark a test suite as not having succeeded-unsetTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+unsetTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) => Path Abs Dir -> m () unsetTestSuccess dir =@@ -215,7 +217,7 @@ False -- | Check if the test suite already passed-checkTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+checkTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) => Path Abs Dir -> m Bool checkTestSuccess dir =@@ -234,7 +236,7 @@ -- | The file containing information on the given package/configuration -- combination. The filename contains a hash of the non-directory configure -- options for quick lookup if there's a match.-precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env)+precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) => PackageIdentifier -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies@@ -255,14 +257,13 @@ -- unnecessarily. -- -- See issue: https://github.com/commercialhaskell/stack/issues/1103- let cacheInput- | envConfigCabalVersion ec >= $(mkVersion "1.22") =- Binary.encode $ coNoDirs copts- | otherwise =- Binary.encode- ( coNoDirs copts- , installedPackageIDs- )+ let computeCacheSource input = do+ $logDebug $ "Precompiled cache input = " <> T.pack (show input)+ return $ Binary.encode input+ cacheInput <-+ if envConfigCabalVersion ec >= $(mkVersion "1.22")+ then computeCacheSource (coNoDirs copts)+ else computeCacheSource (coNoDirs copts, installedPackageIDs) -- 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.@@ -279,7 +280,7 @@ </> copts' -- | Write out information about a newly built package-writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)+writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m) => BaseConfigOpts -> PackageIdentifier -> ConfigureOpts@@ -306,7 +307,7 @@ -- | Check the cache for a precompiled package matching the given -- configuration.-readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)+readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m) => PackageIdentifier -- ^ target package -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies
src/Stack/Build/ConstructPlan.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -34,6 +35,8 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Distribution.Package as Cabal import qualified Distribution.Version as Cabal+import GHC.Generics (Generic)+import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Network.HTTP.Client.Conduit (HasHttpManager) import Prelude hiding (pi, writeFile) import Stack.Build.Cache@@ -85,10 +88,10 @@ -- ^ Packages which count as dependencies , wWarnings :: !([Text] -> [Text]) -- ^ Warnings- }+ } deriving Generic instance Monoid W where- mempty = W mempty mempty mempty mempty mempty- mappend (W a b c d e) (W w x y z z') = W (mappend a w) (mappend b x) (mappend c y) (mappend d z) (mappend e z')+ mempty = memptydefault+ mappend = mappenddefault type M = RWST Ctx@@ -99,7 +102,7 @@ data Ctx = Ctx { mbp :: !MiniBuildPlan , baseConfigOpts :: !BaseConfigOpts- , loadPackage :: !(PackageName -> Version -> Map FlagName Bool -> IO Package)+ , loadPackage :: !(PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) , combinedMap :: !CombinedMap , toolToPackages :: !(Cabal.Dependency -> Map PackageName VersionRange) , ctxEnvConfig :: !EnvConfig@@ -126,7 +129,7 @@ -> [LocalPackage] -> Set PackageName -- ^ additional packages that must be built -> [DumpPackage () ()] -- ^ locally registered- -> (PackageName -> Version -> Map FlagName Bool -> IO Package) -- ^ load upstream package+ -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package -> SourceMap -> InstalledMap -> m Plan@@ -202,7 +205,7 @@ case M.lookup name tasks of Nothing -> case M.lookup name sourceMap of- Just (PSUpstream _ Snap _) -> Map.singleton gid+ Just (PSUpstream _ Snap _ _ _) -> Map.singleton gid ( ident , Just "Switching to snapshot installed package" )@@ -231,7 +234,6 @@ (getEnvConfig ctx) (baseConfigOpts ctx) allDeps- True -- wanted True -- local Local package@@ -276,14 +278,16 @@ tellExecutables _ (PSLocal lp) | lpWanted lp = tellExecutablesPackage Local $ lpPackage lp | otherwise = return ()-tellExecutables name (PSUpstream version loc flags) =+-- Ignores ghcOptions because they don't matter for enumerating+-- executables.+tellExecutables name (PSUpstream version loc flags _ghcOptions _gitSha) = tellExecutablesUpstream name version loc flags tellExecutablesUpstream :: PackageName -> Version -> InstallLocation -> Map FlagName Bool -> M () tellExecutablesUpstream name version loc flags = do ctx <- ask when (name `Set.member` extraToBuild ctx) $ do- p <- liftIO $ loadPackage ctx name version flags+ p <- liftIO $ loadPackage ctx name version flags [] tellExecutablesPackage loc p tellExecutablesPackage :: InstallLocation -> Package -> M ()@@ -316,8 +320,8 @@ installPackage treatAsDep name ps minstalled = do ctx <- ask case ps of- PSUpstream version _ flags -> do- package <- liftIO $ loadPackage ctx name version flags+ PSUpstream version _ flags ghcOptions _ -> do+ package <- liftIO $ loadPackage ctx name version flags ghcOptions resolveDepsAndInstall False treatAsDep ps package minstalled PSLocal lp -> case lpTestBench lp of@@ -400,7 +404,6 @@ (getEnvConfig ctx) (baseConfigOpts ctx) allDeps- (psWanted ps) (psLocal ps) -- An assertion to check for a recurrence of -- https://github.com/commercialhaskell/stack/issues/345@@ -410,7 +413,7 @@ , taskType = case ps of PSLocal lp -> TTLocal lp- PSUpstream _ loc _ -> TTUpstream package $ loc <> minLoc+ PSUpstream _ loc _ _ sha -> TTUpstream package (loc <> minLoc) sha , taskAllInOne = isAllInOne } @@ -500,7 +503,6 @@ (getEnvConfig ctx) (baseConfigOpts ctx) present- (psWanted ps) (psLocal ps) (piiLocation ps) -- should be Local always package@@ -596,10 +598,6 @@ psDirty (PSLocal lp) = lpDirtyFiles lp psDirty (PSUpstream {}) = Nothing -- files never change in an upstream package -psWanted :: PackageSource -> Bool-psWanted (PSLocal lp) = lpWanted lp-psWanted (PSUpstream {}) = False- psLocal :: PackageSource -> Bool psLocal (PSLocal _) = True psLocal (PSUpstream {}) = False@@ -667,8 +665,8 @@ checkTask task = case taskType task of TTLocal _ -> False- TTUpstream _ Local -> False- TTUpstream _ Snap -> True+ TTUpstream _ Local _ -> False+ TTUpstream _ Snap _ -> True stripNonDeps :: Set PackageName -> Plan -> Plan stripNonDeps deps plan = plan
src/Stack/Build/Execute.hs view
@@ -113,7 +113,7 @@ toIdent (name, task) = case taskType task of TTLocal _ -> Set.empty- TTUpstream package _ -> Set.singleton $ PackageIdentifier+ TTUpstream package _ _ -> Set.singleton $ PackageIdentifier name (packageVersion package) @@ -187,7 +187,7 @@ TTLocal lp -> concat [ toFilePath $ lpDir lp ]- TTUpstream _ _ -> "package index"+ TTUpstream _ _ _ -> "package index" , if Set.null missing then "" else ", after: " ++ intercalate "," (map packageIdentifierString $ Set.toList missing)@@ -665,7 +665,7 @@ , configCacheComponents = case taskType of TTLocal lp -> Set.map renderComponent $ lpComponents lp- TTUpstream _ _ -> Set.empty+ TTUpstream _ _ _ -> Set.empty , configCacheHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides) }@@ -764,7 +764,7 @@ wanted = case taskType of TTLocal lp -> lpWanted lp- TTUpstream _ _ -> False+ TTUpstream _ _ _ -> False console = wanted && all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining)@@ -773,9 +773,10 @@ withPackage inner = case taskType of TTLocal lp -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp)- TTUpstream package _ -> do+ TTUpstream package _ gitSHA1 -> do mdist <- liftM Just distRelativeDir- m <- unpackPackageIdents eeEnvOverride eeTempDir mdist $ Set.singleton taskProvides+ m <- unpackPackageIdents eeEnvOverride eeTempDir mdist+ $ Map.singleton taskProvides gitSHA1 case Map.toList m of [(ident, dir)] | ident == taskProvides -> do@@ -820,10 +821,15 @@ (True, Just setupExe) -> return $ Left setupExe _ -> liftIO $ fmap Right $ getSetupHs pkgDir inner $ \stripTHLoading args -> do- let cabalPackageArg =- "-package=" ++ packageIdentifierString- (PackageIdentifier cabalPackageName- eeCabalPkgVer)+ let cabalPackageArg+ -- Omit cabal package dependency when building+ -- Cabal. See+ -- https://github.com/commercialhaskell/stack/issues/1356+ | packageName package == $(mkPackageName "Cabal") = []+ | otherwise =+ ["-package=" ++ packageIdentifierString+ (PackageIdentifier cabalPackageName+ eeCabalPkgVer)] packageArgs = case mdeps of -- This branch is taken when@@ -843,10 +849,10 @@ ) ++ ( ("-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)) : ("-package-db=" ++ toFilePathNoTrailingSep (bcoLocalDB eeBaseConfigOpts))- : "-hide-all-packages"- : cabalPackageArg- : map ("-package-id=" ++) depsMinusCabal- )+ : ["-hide-all-packages"]+ ) +++ cabalPackageArg +++ map ("-package-id=" ++) depsMinusCabal -- This branch is usually taken for builds, and -- is always taken for `stack sdist`. --@@ -865,11 +871,11 @@ -- sdist` or when explicitly requested in the -- stack.yaml file. _ ->- cabalPackageArg- : "-clear-package-db"+ cabalPackageArg +++ ("-clear-package-db" : "-global-package-db" : map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts)- ++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)]+ ++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)]) setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args runExe exeName fullArgs =@@ -988,14 +994,16 @@ (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 `isParentOf`) (parseAbsFile =<< (pcLibrary pc)) ->- -- If old precompiled cache files are left around but snapshots are deleted,- -- it is possible for the precompiled file to refer to the very library- -- we're building, and if flags are changed it may try to copy the library- -- to itself. This check prevents that from happening. return Nothing+ -- If old precompiled cache files are left around but snapshots are deleted,+ -- it is possible for the precompiled file to refer to the very library+ -- we're building, and if flags are changed it may try to copy the library+ -- to itself. This check prevents that from happening. Just pc | otherwise -> do let allM _ [] = return True allM f (x:xs) = do@@ -1078,7 +1086,7 @@ TTLocal lp -> do when enableTests $ unsetTestSuccess pkgDir writeBuildCache pkgDir $ lpNewBuildCache lp- TTUpstream _ _ -> return ()+ TTUpstream _ _ _ -> return () () <- announce ("build" <> annSuffix) config <- asks getConfig@@ -1170,7 +1178,7 @@ unless (null addBuildCache) $ writeBuildCache pkgDir $ Map.unions (lpNewBuildCache lp : addBuildCache)-checkForUnlistedFiles (TTUpstream _ _) _ _ = return ()+checkForUnlistedFiles (TTUpstream _ _ _) _ _ = return () -- | Determine if all of the dependencies given are installed depsPresent :: InstalledMap -> Map PackageName VersionRange -> Bool
src/Stack/Build/Haddock.hs view
@@ -21,7 +21,6 @@ import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class import Control.Monad.Logger-import Control.Monad.Reader import Control.Monad.Trans.Resource import qualified Data.Foldable as F import Data.Function@@ -50,7 +49,7 @@ import Web.Browser (openBrowser) openHaddocksInBrowser- :: (MonadIO m, MonadReader env m, HasBuildConfig env, MonadThrow m, MonadLogger m)+ :: (MonadIO m, MonadThrow m, MonadLogger m) => BaseConfigOpts -> Map PackageName (PackageIdentifier, InstallLocation) -- ^ Available packages and their locations for the current project@@ -111,7 +110,7 @@ -- | Generate Haddock index and contents for local packages. generateLocalHaddockIndex- :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)+ :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m) => EnvOverride -> WhichCompiler -> BaseConfigOpts@@ -130,13 +129,14 @@ "local packages" envOverride wc+ (boptsHaddockOpts (bcoBuildOpts bco)) dumpPackages "." (localDocDir bco) -- | Generate Haddock index and contents for local packages and their dependencies. generateDepsHaddockIndex- :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)+ :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m) => EnvOverride -> WhichCompiler -> BaseConfigOpts@@ -152,6 +152,7 @@ "local packages and dependencies" envOverride wc+ (boptsHaddockOpts (bcoBuildOpts bco)) deps ".." depDocDir@@ -180,7 +181,7 @@ -- | Generate Haddock index and contents for all snapshot packages. generateSnapHaddockIndex- :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)+ :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m) => EnvOverride -> WhichCompiler -> BaseConfigOpts@@ -192,6 +193,7 @@ "snapshot packages" envOverride wc+ (boptsHaddockOpts (bcoBuildOpts bco)) (Map.elems snapshotDumpPkgs ++ Map.elems globalDumpPkgs) "." (snapDocDir bco)@@ -202,11 +204,12 @@ => Text -> EnvOverride -> WhichCompiler+ -> HaddockOpts -> [DumpPackage () ()] -> FilePath -> Path Abs Dir -> m ()-generateHaddockIndex descr envOverride wc dumpPackages docRelFP destDir = do+generateHaddockIndex descr envOverride wc hdopts dumpPackages docRelFP destDir = do ensureDir destDir interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages unless (null interfaceOpts) $ do@@ -226,10 +229,12 @@ (Just destDir) envOverride (haddockExeName wc)- (["--gen-contents", "--gen-index"] ++ [x | (xs,_,_,_) <- interfaceOpts, x <- xs])+ (toHaddockArgs hdopts +++ ["--gen-contents", "--gen-index"] +++ [x | (xs,_,_,_) <- interfaceOpts, x <- xs]) where toInterfaceOpt :: DumpPackage a b -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))- toInterfaceOpt DumpPackage {..} = do+ toInterfaceOpt DumpPackage {..} = case dpHaddockInterfaces of [] -> return Nothing srcInterfaceFP:_ -> do
src/Stack/Build/Source.hs view
@@ -11,64 +11,65 @@ ( loadSourceMap , SourceMap , PackageSource (..)- , localFlags+ , getLocalFlags+ , getGhcOptions , getLocalPackageViews- , loadLocalPackage , parseTargetsFromBuildOpts , addUnlistedToBuildCache+ , getDefaultPackageConfig , getPackageConfig ) where -import Control.Applicative-import Control.Arrow ((&&&))-import Control.Exception (assert, catch)-import Control.Monad-import Control.Monad.Catch (MonadCatch)-import Control.Monad.IO.Class-import Control.Monad.Logger-import Control.Monad.Reader (MonadReader, asks)-import Control.Monad.Trans.Resource+import Control.Applicative+import Control.Arrow ((&&&))+import Control.Exception (assert, catch)+import Control.Monad hiding (sequence)+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader (MonadReader, asks)+import Control.Monad.Trans.Resource import "cryptohash" Crypto.Hash (Digest, SHA256)-import Crypto.Hash.Conduit (sinkHash)-import qualified Data.ByteString as S-import Data.Byteable (toBytes)-import Data.Conduit (($$), ZipSink (..))-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List as CL-import Data.Either-import Data.Function-import qualified Data.HashSet as HashSet-import Data.List-import qualified Data.Map as Map-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Monoid-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Text (Text)-import qualified Data.Text as T-import Distribution.Package (pkgName, pkgVersion)-import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription)-import qualified Distribution.PackageDescription as C-import Network.HTTP.Client.Conduit (HasHttpManager)-import Path-import Path.IO-import Prelude-import Stack.Build.Cache-import Stack.Build.Target-import Stack.BuildPlan (loadMiniBuildPlan, shadowMiniBuildPlan,- parseCustomMiniBuildPlan)-import Stack.Constants (wiredInPackages)-import Stack.Package-import Stack.PackageIndex (getPackageVersions)-import Stack.Types--import qualified System.Directory as D-import System.IO (withBinaryFile, IOMode (ReadMode))-import System.IO.Error (isDoesNotExistError)+import Crypto.Hash.Conduit (sinkHash)+import qualified Data.ByteString as S+import Data.Byteable (toBytes)+import Data.Conduit (($$), ZipSink (..))+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import Data.Either+import Data.Function+import qualified Data.HashSet as HashSet+import Data.List+import qualified Data.Map as Map+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Traversable (sequence)+import Distribution.Package (pkgName, pkgVersion)+import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription)+import qualified Distribution.PackageDescription as C+import Network.HTTP.Client.Conduit (HasHttpManager)+import Path+import Path.IO+import Prelude hiding (sequence)+import Stack.Build.Cache+import Stack.Build.Target+import Stack.BuildPlan (shadowMiniBuildPlan)+import Stack.Constants (wiredInPackages)+import Stack.Package+import Stack.PackageIndex (getPackageVersions)+import Stack.Types+import qualified System.Directory as D+import System.FilePath (takeFileName)+import System.IO (withBinaryFile, IOMode (ReadMode))+import System.IO.Error (isDoesNotExistError) -loadSourceMap :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)+loadSourceMap :: (MonadIO m, MonadMask m, MonadReader env m, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env) => NeedTargets -> BuildOptsCLI -> m ( Map PackageName SimpleTarget@@ -111,27 +112,34 @@ -- Add the extra deps from the stack.yaml file to the deps grabbed from -- the snapshot extraDeps2 = Map.union- (Map.map (\v -> (v, Map.empty)) extraDeps0)- (Map.map (mpiVersion &&& mpiFlags) extraDeps1)+ (Map.map (\v -> (v, Map.empty, [])) extraDeps0)+ (Map.map (\mpi -> (mpiVersion mpi, mpiFlags mpi, mpiGhcOptions mpi)) extraDeps1) - -- Overwrite any flag settings with those from the config file+ -- Add flag and ghc-option settings from the config file / cli extraDeps3 = Map.mapWithKey- (\n (v, f) -> PSUpstream v Local $- case ( Map.lookup (Just n) $ boptsCLIFlags boptsCli- , Map.lookup Nothing $ boptsCLIFlags boptsCli- , Map.lookup n $ bcFlags bconfig- ) of- -- Didn't have any flag overrides, fall back to the flags- -- defined in the snapshot.- (Nothing, Nothing, Nothing) -> f- -- Either command line flag for this package, general- -- command line flag, or flag in stack.yaml is defined.- -- Take all of those and ignore the snapshot flags.- (x, y, z) -> Map.unions- [ fromMaybe Map.empty x- , fromMaybe Map.empty y- , fromMaybe Map.empty z- ])+ (\n (v, flags0, ghcOptions0) ->+ let flags =+ case ( Map.lookup (Just n) $ boptsCLIFlags boptsCli+ , Map.lookup Nothing $ boptsCLIFlags boptsCli+ , Map.lookup n $ unPackageFlags $ bcFlags bconfig+ ) of+ -- Didn't have any flag overrides, fall back to the flags+ -- defined in the snapshot.+ (Nothing, Nothing, Nothing) -> flags0+ -- Either command line flag for this package, general+ -- command line flag, or flag in stack.yaml is defined.+ -- Take all of those and ignore the snapshot flags.+ (x, y, z) -> Map.unions+ [ fromMaybe Map.empty x+ , fromMaybe Map.empty y+ , fromMaybe Map.empty z+ ]+ ghcOptions =+ ghcOptions0 +++ getGhcOptions bconfig boptsCli n False False+ -- currently have no ability for extra-deps to specify their+ -- cabal file hashes+ in PSUpstream v Local flags ghcOptions Nothing) extraDeps2 let sourceMap = Map.unions@@ -140,14 +148,48 @@ in (packageName p, PSLocal lp) , extraDeps3 , flip fmap (mbpPackages mbp) $ \mpi ->- PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi)+ PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi) (mpiGhcOptions mpi) (mpiGitSHA1 mpi) ] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) return (targets, mbp, locals, nonLocalTargets, sourceMap) +-- | All flags for a local package+getLocalFlags+ :: BuildConfig+ -> 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 (unPackageFlags (bcFlags bconfig))+ ]+ where+ cliFlags = boptsCLIFlags boptsCli++getGhcOptions :: BuildConfig -> BuildOptsCLI -> PackageName -> Bool -> Bool -> [Text]+getGhcOptions bconfig boptsCli name isTarget isLocal = concat+ [ ghcOptionsFor name (configGhcOptions config)+ , concat [["-fhpc"] | isLocal && toCoverage (boptsTestOpts bopts)]+ , if (boptsLibProfile bopts || boptsExeProfile bopts)+ then ["-auto-all","-caf-all"]+ else []+ , if includeExtraOptions+ then boptsCLIGhcOptions boptsCli+ else []+ ]+ where+ bopts = configBuild config+ config = bcConfig bconfig+ includeExtraOptions =+ case configApplyGhcOptions config of+ AGOTargets -> isTarget+ AGOLocals -> isLocal+ AGOEverything -> True+ -- | Use the build options and environment to parse targets. parseTargetsFromBuildOpts- :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)+ :: (MonadIO m, MonadMask m, MonadReader env m, MonadLogger m, HasEnvConfig env) => NeedTargets -> BuildOptsCLI -> m (MiniBuildPlan, M.Map PackageName Version, M.Map PackageName SimpleTarget)@@ -155,9 +197,6 @@ bconfig <- asks getBuildConfig mbp0 <- case bcResolver bconfig of- ResolverSnapshot snapName -> do- $logDebug $ "Checking resolver: " <> renderSnapName snapName- loadMiniBuildPlan snapName ResolverCompiler _ -> do -- We ignore the resolver version, as it might be -- GhcMajorVersion, and we want the exact version@@ -167,9 +206,7 @@ { mbpCompilerVersion = version , mbpPackages = Map.empty }- ResolverCustom _ url -> do- stackYamlFP <- asks $ bcStackYaml . getBuildConfig- parseCustomMiniBuildPlan stackYamlFP url+ _ -> return (bcWantedMiniBuildPlan bconfig) rawLocals <- getLocalPackageViews workingDir <- getCurrentDir @@ -275,17 +312,17 @@ -- based on the selected components loadLocalPackage :: forall m env.- (MonadReader env m, HasEnvConfig env, MonadCatch m, MonadLogger m, MonadIO m)+ (MonadReader env m, HasEnvConfig env, MonadMask m, MonadLogger m, MonadIO m) => BuildOptsCLI -> Map PackageName SimpleTarget -> (PackageName, (LocalPackageView, GenericPackageDescription)) -> m LocalPackage loadLocalPackage boptsCli targets (name, (lpv, gpkg)) = do- config <- getPackageConfig boptsCli name+ let mtarget = Map.lookup name targets+ config <- getPackageConfig boptsCli name (isJust mtarget) True bopts <- asks (configBuild . getConfig) let pkg = resolvePackage config gpkg - mtarget = Map.lookup name targets (exes, tests, benches) = case mtarget of Just (STLocalComps comps) -> splitComponents $ Set.toList comps@@ -329,12 +366,9 @@ mbuildCache <- tryGetBuildCache $ lpvRoot lpv (files,_) <- getPackageFilesSimple pkg (lpvCabalFP lpv) - -- Filter out the cabal_macros file to avoid spurious recompilations- let filteredFiles = Set.filter ((/= $(mkRelFile "cabal_macros.h")) . filename) files- (dirtyFiles, newBuildCache) <- checkBuildCache (fromMaybe Map.empty mbuildCache)- (map toFilePath $ Set.toList filteredFiles)+ (Set.toList files) return LocalPackage { lpPackage = pkg@@ -380,7 +414,7 @@ -- 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)+ ++ map (, FSStackYaml) (Map.toList $ unPackageFlags $ bcFlags bconfig) localNameMap = Map.fromList $ map (packageName . lpPackage &&& lpPackage) lps checkFlagUsed ((name, userFlags), source) =@@ -411,24 +445,13 @@ $ InvalidFlagSpecification $ Set.fromList unusedFlags --- | All flags for a local package-localFlags :: Map (Maybe PackageName) (Map FlagName Bool)- -> BuildConfig- -> PackageName- -> Map FlagName Bool-localFlags boptsflags bconfig name = Map.unions- [ Map.findWithDefault Map.empty (Just name) boptsflags- , Map.findWithDefault Map.empty Nothing boptsflags- , Map.findWithDefault Map.empty name (bcFlags bconfig)- ]- -- | Add in necessary packages to extra dependencies -- -- Originally part of https://github.com/commercialhaskell/stack/issues/272, -- this was then superseded by -- https://github.com/commercialhaskell/stack/issues/651 extendExtraDeps- :: (HasBuildConfig env, MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)+ :: (HasBuildConfig env, MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, MonadMask m) => Map PackageName Version -- ^ original extra deps -> Map PackageName Version -- ^ package identifiers from the command line -> Set PackageName -- ^ all packages added on the command line@@ -459,37 +482,45 @@ -- | Compare the current filesystem state to the cached information, and -- determine (1) if the files are dirty, and (2) the new cache values.-checkBuildCache :: MonadIO m+checkBuildCache :: forall m. (MonadIO m) => Map FilePath FileCacheInfo -- ^ old cache- -> [FilePath] -- ^ files in package+ -> [Path Abs File] -- ^ files in package -> m (Set FilePath, Map FilePath FileCacheInfo)-checkBuildCache oldCache files = liftIO $ do- (dirtyFiles, m) <- mconcat <$> mapM go files- return (dirtyFiles, m)+checkBuildCache oldCache files = do+ fileTimes <- liftM Map.fromList $ forM files $ \fp -> do+ mmodTime <- liftIO (getModTimeMaybe (toFilePath fp))+ return (toFilePath fp, mmodTime)+ liftM (mconcat . Map.elems) $ sequence $+ Map.mergeWithKey+ (\fp mmodTime fci -> Just (go fp mmodTime (Just fci)))+ (Map.mapWithKey (\fp mmodTime -> go fp mmodTime Nothing))+ (Map.mapWithKey (\fp fci -> go fp Nothing (Just fci)))+ fileTimes+ oldCache where- go fp = do- mmodTime <- getModTimeMaybe fp- case mmodTime of- Nothing -> return (Set.empty, Map.empty)- Just modTime' -> do- (isDirty, newFci) <-- case Map.lookup fp oldCache of- Just fci- | fciModTime fci == modTime' -> return (False, fci)- | otherwise -> do- newFci <- calcFci modTime' fp- let isDirty =- fciSize fci /= fciSize newFci ||- fciHash fci /= fciHash newFci- return (isDirty, newFci)- Nothing -> do- newFci <- calcFci modTime' fp- return (True, newFci)- return (if isDirty then Set.singleton fp else Set.empty, Map.singleton fp newFci)+ go :: FilePath -> Maybe ModTime -> 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.+ go fp (Just modTime') (Just fci)+ | fciModTime fci == modTime' = return (Set.empty, Map.empty)+ | otherwise = do+ newFci <- calcFci modTime' fp+ let isDirty =+ fciSize fci /= fciSize newFci ||+ fciHash fci /= fciHash newFci+ newDirty = if isDirty then Set.singleton fp else Set.empty+ return (newDirty, Map.singleton fp newFci)+ -- Missing file. Add it to dirty files, but no FileCacheInfo.+ go fp Nothing _ = return (Set.singleton fp, Map.empty)+ -- Missing cache. Add it to dirty files and compute FileCacheInfo.+ go fp (Just modTime') Nothing = do+ newFci <- calcFci modTime' fp+ return (Set.singleton fp, Map.singleton fp newFci) -- | Returns entries to add to the build cache for any newly found unlisted modules addUnlistedToBuildCache- :: (MonadIO m, MonadReader env m, MonadCatch m, MonadLogger m, HasEnvConfig env)+ :: (MonadIO m, MonadReader env m, MonadMask m, MonadLogger m, HasEnvConfig env) => ModTime -> Package -> Path Abs File@@ -516,7 +547,7 @@ -- | Gets list of Paths for files in a package getPackageFilesSimple- :: (MonadIO m, MonadReader env m, MonadCatch m, MonadLogger m, HasEnvConfig env)+ :: (MonadIO m, MonadReader env m, MonadMask m, MonadLogger m, HasEnvConfig env) => Package -> Path Abs File -> m (Set (Path Abs File), [PackageWarning]) getPackageFilesSimple pkg cabalFP = do (_,compFiles,cabalFiles,warnings) <-@@ -564,18 +595,35 @@ , c <- Set.toList (lpUnbuildable lp) ] +getDefaultPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env)+ => m PackageConfig+getDefaultPackageConfig = do+ econfig <- asks getEnvConfig+ bconfig <- asks getBuildConfig+ return PackageConfig+ { packageConfigEnableTests = False+ , packageConfigEnableBenchmarks = False+ , packageConfigFlags = M.empty+ , packageConfigGhcOptions = []+ , packageConfigCompilerVersion = envConfigCompilerVersion econfig+ , packageConfigPlatform = configPlatform $ getConfig bconfig+ }+ -- | Get 'PackageConfig' for package given its name.-getPackageConfig :: (MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m, MonadReader env m, HasEnvConfig env)+getPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env) => BuildOptsCLI -> PackageName+ -> Bool+ -> Bool -> m PackageConfig-getPackageConfig boptsCli name = do+getPackageConfig boptsCli name isTarget isLocal = do econfig <- asks getEnvConfig bconfig <- asks getBuildConfig return PackageConfig { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False- , packageConfigFlags = localFlags (boptsCLIFlags boptsCli) bconfig name+ , packageConfigFlags = getLocalFlags bconfig boptsCli name+ , packageConfigGhcOptions = getGhcOptions bconfig boptsCli name isTarget isLocal , packageConfigCompilerVersion = envConfigCompilerVersion econfig , packageConfigPlatform = configPlatform $ getConfig bconfig }
src/Stack/BuildPlan.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}@@ -20,6 +21,7 @@ , gpdPackageName , MiniBuildPlan(..) , MiniPackageInfo(..)+ , loadResolver , loadMiniBuildPlan , removeSrcPkgDefaultFlags , resolveBuildPlan@@ -33,7 +35,7 @@ import Control.Applicative import Control.Exception (assert)-import Control.Monad (liftM, forM)+import Control.Monad (liftM, forM, unless) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger@@ -42,10 +44,10 @@ put) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256-import Data.Aeson.Extended (FromJSON (..), withObject, (.:), (.:?), (.!=))-import Data.Binary.VersionTagged (taggedDecodeOrLoad)+import Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings)+import Data.Binary.VersionTagged (taggedDecodeOrLoad, decodeFileOrFailDeep, taggedEncodeFile) import qualified Data.ByteString as S-import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString.Char8 as S8 import Data.Either (partitionEithers) import qualified Data.Foldable as F@@ -55,7 +57,7 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (fromMaybe, mapMaybe)+import Data.Maybe (fromMaybe, mapMaybe, isNothing) import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set@@ -86,8 +88,6 @@ import Stack.PackageIndex import Stack.Types import Stack.Types.StackT-import qualified System.Directory as D-import qualified System.FilePath as FP data BuildPlanException = UnknownPackages@@ -95,6 +95,8 @@ (Map PackageName (Maybe Version, Set PackageName)) -- truly unknown (Map PackageName (Set PackageIdentifier)) -- shadowed | SnapshotNotFound SnapName+ | FilepathInDownloadedSnapshot T.Text+ | NeitherCompilerOrResolverSpecified T.Text deriving (Typeable) instance Exception BuildPlanException instance Show BuildPlanException where@@ -174,6 +176,15 @@ $ Set.toList $ Set.unions $ Map.elems shadowed+ show (FilepathInDownloadedSnapshot url) = unlines+ [ "Downloaded snapshot specified a 'resolver: { location: filepath }' "+ , "field, but filepaths are not allowed in downloaded snapshots.\n"+ , "Filepath specified: " ++ T.unpack url+ ]+ show (NeitherCompilerOrResolverSpecified url) =+ "Failed to load custom snapshot at " +++ T.unpack url +++ ", because no 'compiler' or 'resolver' is specified." -- | Determine the necessary packages to install to have the given set of -- packages available.@@ -214,21 +225,19 @@ , rsUsedBy :: Map PackageName (Set PackageName) } -toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m)+toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadMask m, HasConfig env, MonadBaseControl IO m) => CompilerVersion -- ^ Compiler version -> Map PackageName Version -- ^ cores- -> Map PackageName (Version, Map FlagName Bool) -- ^ non-core packages+ -> Map PackageName (Version, Map FlagName Bool, [Text], Maybe GitSHA1) -- ^ non-core packages -> m MiniBuildPlan toMiniBuildPlan compilerVersion corePackages packages = do- $logInfo "Caching build plan"- -- Determine the dependencies of all of the packages in the build plan. We -- handle core packages specially, because some of them will not be in the -- package index. For those, we allow missing packages to exist, and then -- remove those from the list of dependencies, since there's no way we'll -- ever reinstall them anyway. (cores, missingCores) <- addDeps True compilerVersion- $ fmap (, Map.empty) corePackages+ $ fmap (, Map.empty, [], Nothing) corePackages (extras, missing) <- addDeps False compilerVersion packages @@ -244,10 +253,12 @@ goCore (PackageIdentifier name version) = (name, MiniPackageInfo { mpiVersion = version , mpiFlags = Map.empty+ , mpiGhcOptions = [] , mpiPackageDeps = Set.empty , mpiToolDeps = Set.empty , mpiExes = Set.empty , mpiHasLibrary = True+ , mpiGitSHA1 = Nothing }) removeMissingDeps cores mpi = mpi@@ -255,10 +266,10 @@ } -- | Add in the resolved dependencies from the package index-addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m)+addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadMask m, HasConfig env, MonadBaseControl IO m) => Bool -- ^ allow missing -> CompilerVersion -- ^ Compiler version- -> Map PackageName (Version, Map FlagName Bool)+ -> Map PackageName (Version, Map FlagName Bool, [Text], Maybe GitSHA1) -> m (Map PackageName MiniPackageInfo, Set PackageIdentifier) addDeps allowMissing compilerVersion toCalc = do menv <- getMinimalEnvOverride@@ -267,26 +278,32 @@ if allowMissing then do (missingNames, missingIdents, m) <-- resolvePackagesAllowMissing (Map.keysSet idents0) Set.empty+ resolvePackagesAllowMissing shaMap Set.empty assert (Set.null missingNames) $ return (m, missingIdents) else do- m <- resolvePackages menv (Map.keysSet idents0) Set.empty+ m <- resolvePackages menv shaMap Set.empty return (m, Set.empty) let byIndex = Map.fromListWith (++) $ flip map (Map.toList resolvedMap) $ \(ident, rp) ->- (indexName $ rpIndex rp,+ let (cache, ghcOptions, sha) =+ case Map.lookup (packageIdentifierName ident) toCalc of+ Nothing -> (Map.empty, [], Nothing)+ Just (_, x, y, z) -> (x, y, z)+ in (indexName $ rpIndex rp, [( ident , rpCache rp- , maybe Map.empty snd $ Map.lookup (packageIdentifierName ident) toCalc+ , sha+ , (cache, ghcOptions, sha) )]) res <- forM (Map.toList byIndex) $ \(indexName', pkgs) -> withCabalFiles indexName' pkgs- $ \ident flags cabalBS -> do+ $ \ident (flags, ghcOptions, mgitSha) cabalBS -> do (_warnings,gpd) <- readPackageUnresolvedBS Nothing cabalBS let packageConfig = PackageConfig { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False , packageConfigFlags = flags+ , packageConfigGhcOptions = ghcOptions , packageConfigCompilerVersion = compilerVersion , packageConfigPlatform = platform }@@ -297,6 +314,7 @@ return (name, MiniPackageInfo { mpiVersion = packageIdentifierVersion ident , mpiFlags = flags+ , mpiGhcOptions = ghcOptions , mpiPackageDeps = notMe $ packageDependencies pd , mpiToolDeps = Map.keysSet $ packageToolDependencies pd , mpiExes = exes@@ -304,11 +322,12 @@ False (buildable . libBuildInfo) (library pd)+ , mpiGitSHA1 = mgitSha }) return (Map.fromList $ concat res, missingIdents) where- idents0 = Map.fromList- $ map (\(n, (v, f)) -> (PackageIdentifier n v, Left f))+ shaMap = Map.fromList+ $ map (\(n, (v, _f, _ghcOptions, gitsha)) -> (PackageIdentifier n v, gitsha)) $ Map.toList toCalc -- | Resolve all packages necessary to install for the needed packages.@@ -397,9 +416,32 @@ $ Set.toList $ mpiExes mpi +loadResolver+ :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadMask m)+ => Maybe (Path Abs File)+ -> Resolver+ -> m (MiniBuildPlan, LoadedResolver)+loadResolver mconfigPath resolver =+ case resolver of+ ResolverSnapshot snap ->+ liftM (, ResolverSnapshot snap) $ loadMiniBuildPlan snap+ -- TODO(mgsloan): Not sure what this FIXME means+ -- FIXME instead of passing the stackYaml dir we should maintain+ -- the file URL in the custom resolver always relative to stackYaml.+ ResolverCustom name url -> do+ (mbp, hash) <- parseCustomMiniBuildPlan mconfigPath url+ return (mbp, ResolverCustomLoaded name url hash)+ ResolverCompiler compiler -> return+ ( MiniBuildPlan+ { mbpCompilerVersion = compiler+ , mbpPackages = mempty+ }+ , ResolverCompiler compiler+ )+ -- | Load up a 'MiniBuildPlan', preferably from cache loadMiniBuildPlan- :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadCatch m)+ :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadMask m) => SnapName -> m MiniBuildPlan loadMiniBuildPlan name = do@@ -414,6 +456,12 @@ goPP pp = ( ppVersion pp , pcFlagOverrides $ ppConstraints pp+ -- TODO: store ghc options in BuildPlan?+ , []+ , ppCabalFileInfo pp+ >>= fmap (GitSHA1 . encodeUtf8)+ . Map.lookup "GitSHA1"+ . cfiHashes ) -- | Some hard-coded fixes for build plans, hopefully to be irrelevant over@@ -434,7 +482,7 @@ -- | Load the 'BuildPlan' for the given snapshot. Will load from a local copy -- if available, otherwise downloading from Github.-loadBuildPlan :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasStackRoot env, HasConfig env)+loadBuildPlan :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env) => SnapName -> m BuildPlan loadBuildPlan name = do@@ -498,6 +546,7 @@ { packageConfigEnableTests = True , packageConfigEnableBenchmarks = True , packageConfigFlags = flags+ , packageConfigGhcOptions = [] , packageConfigCompilerVersion = cv , packageConfigPlatform = platform }@@ -590,7 +639,7 @@ -> Map PackageName Version -- ^ Available package pool or index -> DepErrors checkPackageDeps myName deps packages =- Map.unionsWith mappend $ map go $ Map.toList deps+ Map.unionsWith combineDepError $ map go $ Map.toList deps where go :: (PackageName, VersionRange) -> DepErrors go (name, range) =@@ -611,12 +660,12 @@ { deVersion :: !(Maybe Version) , deNeededBy :: !(Map PackageName VersionRange) } deriving Show-instance Monoid DepError where- mempty = DepError Nothing Map.empty- mappend (DepError a x) (DepError b y) = DepError- (maybe a Just b)- (Map.unionWith C.intersectVersionRanges x y) +-- | Combine two 'DepError's for the same 'Version'.+combineDepError :: DepError -> DepError -> DepError+combineDepError (DepError a x) (DepError b y) =+ assert (a == b) $ DepError a (Map.unionWith C.intersectVersionRanges x y)+ -- | Given a bundle of packages (a list of @GenericPackageDescriptions@'s) to -- build and an available package pool (snapshot) check whether the bundle's -- dependencies can be satisfied. If flags is passed as Nothing flag settings@@ -630,7 +679,7 @@ -> (Map PackageName (Map FlagName Bool), DepErrors) checkBundleBuildPlan platform compiler pool flags gpds = (Map.unionsWith dupError (map fst plans)- , Map.unionsWith mappend (map snd plans))+ , Map.unionsWith combineDepError (map snd plans)) where plans = map (pkgPlan flags) gpds@@ -672,7 +721,7 @@ -- given snapshot. Returns how well the snapshot satisfies the dependencies of -- the packages. checkSnapBuildPlan- :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m+ :: ( MonadIO m, MonadMask m, MonadLogger m, MonadReader env m , HasHttpManager env, HasConfig env, HasGHCVariant env , MonadBaseControl IO m) => [GenericPackageDescription]@@ -707,7 +756,7 @@ -- | Find a snapshot and set of flags that is compatible with and matches as -- best as possible with the given 'GenericPackageDescription's. selectBestSnapshot- :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m+ :: ( MonadIO m, MonadMask m, MonadLogger m, MonadReader env m , HasHttpManager env, HasConfig env, HasGHCVariant env , MonadBaseControl IO m) => [GenericPackageDescription]@@ -829,7 +878,7 @@ -> Set PackageName -> (MiniBuildPlan, Map PackageName MiniPackageInfo) shadowMiniBuildPlan (MiniBuildPlan cv pkgs0) shadowed =- (MiniBuildPlan cv $ Map.fromList met, Map.fromList unmet)+ (MiniBuildPlan cv (Map.fromList met), Map.fromList unmet) where pkgs1 = Map.difference pkgs0 $ Map.fromSet (\_ -> ()) shadowed @@ -871,62 +920,185 @@ Just False -> Right Nothing -> assert False Right -parseCustomMiniBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)- => Path Abs File -- ^ stack.yaml file location- -> T.Text -> m MiniBuildPlan-parseCustomMiniBuildPlan stackYamlFP url0 = do- yamlFP <- getYamlFP url0+-- This works differently for snapshots fetched from URL and those+-- fetched from file:+--+-- 1) If downloading the snapshot from a URL, assume the fetched data is+-- immutable. Hash the URL in order to determine the location of the+-- cached download. The file contents of the snapshot determines the+-- hash for looking up cached MBP.+--+-- 2) If loading the snapshot from a file, load all of the involved+-- snapshot files. The hash used to determine the cached MBP is the hash+-- of the concatenation of the parent's hash with the snapshot contents.+--+-- Why this difference? We want to make it easy to simply edit snapshots+-- in the filesystem, but we want caching for remote snapshots. In order+-- to avoid reparsing / reloading all the yaml for remote snapshots, we+-- need a different hash system. - yamlBS <- liftIO $ S.readFile $ toFilePath yamlFP- let yamlHash = S8.unpack $ B16.encode $ SHA256.hash yamlBS- binaryFilename <- parseRelFile $ yamlHash ++ ".bin"- customPlanDir <- getCustomPlanDir- let binaryFP = customPlanDir </> $(mkRelDir "bin") </> binaryFilename+-- TODO: This could probably be more efficient if it first merged the+-- custom snapshots, and then applied them to the MBP. It is nice to+-- apply directly, because then we have the guarantee that it's+-- semantically identical to snapshot extension. If this optimization is+-- implemented, note that the direct Monoid for CustomSnapshot is not+-- correct. Crucially, if a package is present in the snapshot, its+-- flags and ghc-options are not based on settings from prior snapshots.+-- TODO: This semantics should be discussed / documented more. - taggedDecodeOrLoad binaryFP $ do- cs <- either throwM return $ decodeEither' yamlBS- let addFlags :: PackageIdentifier -> (PackageName, (Version, Map FlagName Bool))- addFlags (PackageIdentifier name ver) =- (name, (ver, fromMaybe Map.empty $ Map.lookup name $ csFlags cs))- toMiniBuildPlan- (csCompilerVersion cs)- Map.empty- (Map.fromList $ map addFlags $ Set.toList $ csPackages cs)- where- getCustomPlanDir = do- root <- asks $ configStackRoot . getConfig- return $ root </> $(mkRelDir "custom-plan")+-- TODO: allow a hash check in the resolver. This adds safety /+-- correctness, allowing you to ensure that you are indeed getting the+-- right custom snapshot. - -- Get the path to the YAML file- getYamlFP url =- case parseUrl $ T.unpack url of- Just req -> getYamlFPFromReq url req- Nothing -> getYamlFPFromFile url+-- TODO: Allow custom plan to specify a name. - getYamlFPFromReq url req = do- let hashStr = S8.unpack $ B16.encode $ SHA256.hash $ encodeUtf8 url- hashFP <- parseRelFile $ hashStr ++ ".yaml"+parseCustomMiniBuildPlan+ :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m)+ => Maybe (Path Abs File) -- ^ Root directory for when url is a filepath+ -> T.Text+ -> m (MiniBuildPlan, SnapshotHash)+parseCustomMiniBuildPlan mconfigPath0 url0 = do+ $logDebug $ "Loading " <> url0 <> " build plan"+ case parseUrl $ T.unpack url0 of+ Just req -> downloadCustom url0 req+ Nothing ->+ case mconfigPath0 of+ Nothing -> throwM $ FilepathInDownloadedSnapshot url0+ Just configPath -> do+ (getMbp, hash) <- readCustom configPath url0+ mbp <- getMbp+ -- NOTE: We make the choice of only writing a cache+ -- file for the full MBP, not the intermediate ones.+ -- This isn't necessarily the best choice if we want+ -- to share work extended snapshots. I think only+ -- writing this one is more efficient for common+ -- cases.+ binaryPath <- getBinaryPath hash+ alreadyCached <- doesFileExist binaryPath+ unless alreadyCached $ taggedEncodeFile binaryPath mbp+ return (mbp, hash)+ where+ downloadCustom url req = do+ let urlHash = S8.unpack $ trimmedSnapshotHash $ doHash $ encodeUtf8 url+ hashFP <- parseRelFile $ urlHash ++ ".yaml" customPlanDir <- getCustomPlanDir- let cacheFP = customPlanDir </> $(mkRelDir "yaml") </> hashFP _ <- download req cacheFP- return cacheFP-- getYamlFPFromFile url = do- fp <- liftIO $ D.canonicalizePath $ toFilePath (parent stackYamlFP) FP.</> T.unpack (fromMaybe url $- T.stripPrefix "file://" url <|> T.stripPrefix "file:" url)- parseAbsFile fp+ yamlBS <- liftIO $ S.readFile $ toFilePath cacheFP+ let yamlHash = doHash yamlBS+ binaryPath <- getBinaryPath yamlHash+ liftM (, yamlHash) $ taggedDecodeOrLoad binaryPath $ do+ (cs, mresolver) <- decodeYaml yamlBS+ parentMbp <- case (csCompilerVersion cs, mresolver) of+ (Nothing, Nothing) -> throwM (NeitherCompilerOrResolverSpecified url)+ (Just cv, Nothing) -> return (compilerBuildPlan cv)+ -- NOTE: ignoring the parent's hash, even though+ -- there could be one. URL snapshot's hash are+ -- determined just from their contents.+ (_, Just resolver) -> liftM fst (loadResolver Nothing resolver)+ applyCustomSnapshot cs parentMbp+ readCustom configPath path = do+ yamlFP <- resolveFile (parent configPath) (T.unpack $ fromMaybe path $+ T.stripPrefix "file://" path <|> T.stripPrefix "file:" path)+ yamlBS <- liftIO $ S.readFile $ toFilePath yamlFP+ (cs, mresolver) <- decodeYaml yamlBS+ (getMbp, hash) <- case mresolver of+ Just (ResolverCustom _ url ) ->+ case parseUrl $ T.unpack url of+ Just req -> do+ let getMbp = do+ -- Ignore custom hash, under the+ -- assumption that the URL is sufficient+ -- for identity.+ (mbp, _) <- downloadCustom url req+ return mbp+ return (getMbp, doHash yamlBS)+ Nothing -> do+ (getMbp0, SnapshotHash hash0) <- readCustom yamlFP url+ let hash = doHash (hash0 <> yamlBS)+ getMbp = do+ binaryPath <- getBinaryPath hash+ -- Idea here is to not waste time+ -- writing out intermediate cache files,+ -- but check for them.+ exists <- doesFileExist binaryPath+ if exists+ then do+ eres <- decodeFileOrFailDeep binaryPath+ case eres of+ Right (Just mbp) -> return mbp+ -- Invalid format cache file, remove.+ _ -> do+ removeFile binaryPath+ getMbp0+ else getMbp0+ return (getMbp, hash)+ Just resolver -> do+ -- NOTE: in the cases where we don't have a hash, the+ -- normal resolver name is enough. Since this name is+ -- part of the yaml file, it ends up in our hash.+ let hash = doHash yamlBS+ getMbp = do+ (mbp, resolver') <- loadResolver (Just configPath) resolver+ let mhash = customResolverHash resolver'+ assert (isNothing mhash) (return mbp)+ return (getMbp, hash)+ Nothing -> do+ case csCompilerVersion cs of+ Nothing -> throwM (NeitherCompilerOrResolverSpecified path)+ Just cv -> do+ let hash = doHash yamlBS+ getMbp = return (compilerBuildPlan cv)+ return (getMbp, hash)+ return (applyCustomSnapshot cs =<< getMbp, hash)+ getBinaryPath hash = do+ binaryFilename <- parseRelFile $ S8.unpack (trimmedSnapshotHash hash) ++ ".bin"+ customPlanDir <- getCustomPlanDir+ return $ customPlanDir </> $(mkRelDir "bin") </> binaryFilename+ decodeYaml yamlBS = do+ WithJSONWarnings res warnings <-+ either (throwM . ParseCustomSnapshotException url0) return $+ decodeEither' yamlBS+ logJSONWarnings (T.unpack url0) warnings+ return res+ compilerBuildPlan cv = MiniBuildPlan+ { mbpCompilerVersion = cv+ , mbpPackages = mempty+ }+ getCustomPlanDir = do+ root <- asks $ configStackRoot . getConfig+ return $ root </> $(mkRelDir "custom-plan")+ doHash = SnapshotHash . B64URL.encode . SHA256.hash -data CustomSnapshot = CustomSnapshot- { csCompilerVersion :: !CompilerVersion- , csPackages :: !(Set PackageIdentifier)- , csFlags :: !(Map PackageName (Map FlagName Bool))- }-instance FromJSON CustomSnapshot where- parseJSON = withObject "CustomSnapshot" $ \o -> CustomSnapshot- <$> ((o .: "compiler") >>= \t ->- case parseCompilerVersion t of- Nothing -> fail $ "Invalid compiler: " ++ T.unpack t- Just compilerVersion -> return compilerVersion)- <*> o .: "packages"- <*> o .:? "flags" .!= Map.empty+applyCustomSnapshot+ :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadMask m)+ => CustomSnapshot+ -> MiniBuildPlan+ -> m MiniBuildPlan+applyCustomSnapshot cs mbp0 = do+ let CustomSnapshot mcompilerVersion+ packages+ dropPackages+ (PackageFlags flags)+ ghcOptions+ = cs+ addFlagsAndOpts :: PackageIdentifier -> (PackageName, (Version, Map FlagName Bool, [Text], Maybe GitSHA1))+ addFlagsAndOpts (PackageIdentifier name ver) =+ ( name+ , ( ver+ , Map.findWithDefault Map.empty name flags+ -- NOTE: similar to 'allGhcOptions' in Stack.Types.Build+ , ghcOptionsFor name ghcOptions+ -- we add a Nothing since we don't yet collect Git SHAs for custom snapshots+ , Nothing+ )+ )+ packageMap = Map.fromList $ map addFlagsAndOpts $ Set.toList packages+ cv = fromMaybe (mbpCompilerVersion mbp0) mcompilerVersion+ packages0 =+ mbpPackages mbp0 `Map.difference` (Map.fromSet (\_ -> ()) dropPackages)+ mbp1 <- toMiniBuildPlan cv mempty packageMap+ return $ MiniBuildPlan+ { mbpCompilerVersion = cv+ , mbpPackages = Map.union (mbpPackages mbp1) packages0+ }
src/Stack/Config.hs view
@@ -24,6 +24,7 @@ module Stack.Config (MiniConfig ,loadConfig+ ,loadConfigMaybeProject ,loadMiniConfig ,packagesParser ,resolvePackageEntry@@ -42,7 +43,7 @@ import Control.Arrow ((***)) import Control.Exception (assert) import Control.Monad (liftM, unless, when, filterM)-import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask, catchAll, throwM)+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask, catchAll, throwM, catch) import Control.Monad.Extra (firstJustM) import Control.Monad.IO.Class import Control.Monad.Logger hiding (Loc)@@ -51,14 +52,14 @@ import qualified Crypto.Hash.SHA256 as SHA256 import Data.Aeson.Extended import qualified Data.ByteString as S-import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString.Lazy as L import Data.Foldable (forM_) import qualified Data.IntMap as IntMap import Data.IORef (newIORef) import qualified Data.Map as Map import Data.Maybe-import Data.Monoid+import Data.Monoid.Extra import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)@@ -137,7 +138,7 @@ stackRoot = configStackRoot config -- | Download the 'Snapshots' value from stackage.org.-getSnapshots :: (MonadThrow m, MonadMask m, MonadIO m, MonadReader env m, HasHttpManager env, HasStackRoot env, HasConfig env, MonadLogger m)+getSnapshots :: (MonadThrow m, MonadMask m, MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m) => m Snapshots getSnapshots = do latestUrlText <- askLatestSnapshotUrl@@ -180,7 +181,7 @@ -- | Get the latest snapshot resolver available. getLatestResolver- :: (MonadIO m, MonadThrow m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m)+ :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m) => m Resolver getLatestResolver = do snapshots <- getSnapshots@@ -192,24 +193,24 @@ -- Interprets ConfigMonoid options. configFromConfigMonoid- :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env)+ :: (MonadLogger m, MonadIO m, MonadCatch m) => Path Abs Dir -- ^ stack root, e.g. ~/.stack -> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml -> Maybe AbstractResolver -> Maybe (Project, Path Abs File) -> ConfigMonoid -> m Config-configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject configMonoid@ConfigMonoid{..} = do- configWorkDir <- parseRelDir (fromMaybe ".stack-work" configMonoidWorkDir)+configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject ConfigMonoid{..} = do+ configWorkDir <- parseRelDir (fromFirst ".stack-work" configMonoidWorkDir) -- This code is to handle the deprecation of latest-snapshot-url- configUrls <- case (configMonoidLatestSnapshotUrl, urlsMonoidLatestSnapshot configMonoidUrls) of+ 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 configConnectionCount = fromMaybe 8 configMonoidConnectionCount- configHideTHLoading = fromMaybe True configMonoidHideTHLoading- configPackageIndices = fromMaybe+ let configConnectionCount = fromFirst 8 configMonoidConnectionCount+ configHideTHLoading = fromFirst True configMonoidHideTHLoading+ configPackageIndices = fromFirst [PackageIndex { indexName = IndexName "Hackage" , indexLocation = ILGitHttp@@ -221,12 +222,12 @@ }] configMonoidPackageIndices - configGHCVariant0 = configMonoidGHCVariant+ configGHCVariant0 = getFirst configMonoidGHCVariant - configSystemGHC = fromMaybe (isNothing configGHCVariant0) configMonoidSystemGHC- configInstallGHC = fromMaybe False configMonoidInstallGHC- configSkipGHCCheck = fromMaybe False configMonoidSkipGHCCheck- configSkipMsys = fromMaybe False configMonoidSkipMsys+ configSystemGHC = fromFirst (isNothing configGHCVariant0) configMonoidSystemGHC+ configInstallGHC = fromFirst False configMonoidInstallGHC+ configSkipGHCCheck = fromFirst False configMonoidSkipGHCCheck+ configSkipMsys = fromFirst False configMonoidSkipMsys configExtraIncludeDirs = configMonoidExtraIncludeDirs configExtraLibDirs = configMonoidExtraLibDirs@@ -235,18 +236,16 @@ -- in the future, allow it to be configured. (Platform defArch defOS) = buildPlatform arch = fromMaybe defArch- $ configMonoidArch >>= Distribution.Text.simpleParse+ $ (getFirst configMonoidArch) >>= Distribution.Text.simpleParse os = fromMaybe defOS- $ configMonoidOS >>= Distribution.Text.simpleParse+ $ (getFirst configMonoidOS) >>= Distribution.Text.simpleParse configPlatform = Platform arch os - configRequireStackVersion = simplifyVersionRange configMonoidRequireStackVersion-- configConfigMonoid = configMonoid+ configRequireStackVersion = simplifyVersionRange (getIntersectingVersionRange configMonoidRequireStackVersion) configImage = Image.imgOptsFromMonoid configMonoidImageOpts - configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck+ configCompilerCheck = fromFirst MatchMinor configMonoidCompilerCheck configPlatformVariant <- liftIO $ maybe PlatformVariantNone PlatformVariant <$> lookupEnv platformVariantEnvVar@@ -274,7 +273,7 @@ let configLocalPrograms = configLocalProgramsBase </> platformOnlyDir configLocalBin <-- case configMonoidLocalBinPath of+ case getFirst configMonoidLocalBinPath of Nothing -> do localDir <- getAppUserDataDir "local" return $ localDir </> $(mkRelDir "bin")@@ -291,25 +290,25 @@ const (throwM (NoSuchDirectory userPath)) configJobs <-- case configMonoidJobs of+ case getFirst configMonoidJobs of Nothing -> liftIO getNumProcessors Just i -> return i- let configConcurrentTests = fromMaybe True configMonoidConcurrentTests+ let configConcurrentTests = fromFirst True configMonoidConcurrentTests let configTemplateParams = configMonoidTemplateParameters- configScmInit = configMonoidScmInit+ configScmInit = getFirst configMonoidScmInit configGhcOptions = configMonoidGhcOptions configSetupInfoLocations = configMonoidSetupInfoLocations- configPvpBounds = fromMaybe PvpBoundsNone configMonoidPvpBounds- configModifyCodePage = fromMaybe True configMonoidModifyCodePage+ configPvpBounds = fromFirst PvpBoundsNone configMonoidPvpBounds+ configModifyCodePage = fromFirst True configMonoidModifyCodePage configExplicitSetupDeps = configMonoidExplicitSetupDeps- configRebuildGhcOptions = fromMaybe False configMonoidRebuildGhcOptions- configApplyGhcOptions = fromMaybe AGOLocals configMonoidApplyGhcOptions- configAllowNewer = fromMaybe False configMonoidAllowNewer- configDefaultTemplate = configMonoidDefaultTemplate+ configRebuildGhcOptions = fromFirst False configMonoidRebuildGhcOptions+ configApplyGhcOptions = fromFirst AGOLocals configMonoidApplyGhcOptions+ configAllowNewer = fromFirst False configMonoidAllowNewer+ configDefaultTemplate = getFirst configMonoidDefaultTemplate configAllowDifferentUser <-- case configMonoidAllowDifferentUser of+ case getFirst configMonoidAllowDifferentUser of Just True -> return True _ -> getInContainer @@ -375,28 +374,28 @@ -- | Load the 'MiniConfig'. loadMiniConfig- :: (MonadIO m, HasHttpManager a, MonadReader a m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)- => Config -> m MiniConfig-loadMiniConfig config = do+ :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)+ => Manager -> Config -> m MiniConfig+loadMiniConfig manager config = do menv <- liftIO $ configEnvOverride config minimalEnvSettings- manager <- getHttpManager <$> ask ghcVariant <- case configGHCVariant0 config of Just ghcVariant -> return ghcVariant Nothing -> getDefaultGHCVariant menv (configPlatform config) return (MiniConfig manager ghcVariant config) --- | Load the configuration, using current directory, environment variables,--- and defaults as necessary.-loadConfig :: (MonadLogger m,MonadIO m,MonadMask m,MonadThrow m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasTerminal env)- => ConfigMonoid- -- ^ Config monoid from parsed command-line arguments- -> Maybe (Path Abs File)- -- ^ Override stack.yaml- -> Maybe AbstractResolver- -- ^ Override resolver- -> m (LoadConfig m)-loadConfig configArgs mstackYaml mresolver = do+-- Load the configuration, using environment variables, and defaults as+-- necessary.+loadConfigMaybeProject+ :: (MonadLogger m,MonadIO m,MonadMask m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasTerminal env)+ => ConfigMonoid+ -- ^ Config monoid from parsed command-line arguments+ -> Maybe AbstractResolver+ -- ^ Override resolver+ -> Maybe (Project, Path Abs File, ConfigMonoid)+ -- ^ Project config to use, if any+ -> m (LoadConfig m)+loadConfigMaybeProject configArgs mresolver mproject = do (stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership configArgs userConfigPath <- getDefaultUserConfigPath stackRoot extraConfigs0 <- getExtraConfigs userConfigPath >>= mapM loadConfigYaml@@ -404,10 +403,8 @@ -- 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 = False}})+ (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = Any False}}) extraConfigs0- mproject <- loadProjectConfig mstackYaml- let mproject' = (\(project, stackYaml, _) -> (project, stackYaml)) <$> mproject config <- configFromConfigMonoid stackRoot userConfigPath mresolver mproject' $ mconcat $ case mproject of@@ -429,6 +426,20 @@ , lcProjectRoot = mprojectRoot } +-- | Load the configuration, using current directory, environment variables,+-- and defaults as necessary. The passed @Maybe (Path Abs File)@ is an+-- override for the location of the project's stack.yaml.+loadConfig :: (MonadLogger m,MonadIO m,MonadMask m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasTerminal env)+ => ConfigMonoid+ -- ^ Config monoid from parsed command-line arguments+ -> Maybe AbstractResolver+ -- ^ Override resolver+ -> Maybe (Path Abs File)+ -- ^ Override stack.yaml+ -> m (LoadConfig m)+loadConfig configArgs mresolver mstackYaml =+ loadProjectConfig mstackYaml >>= loadConfigMaybeProject configArgs mresolver+ -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values. loadBuildConfig :: (MonadLogger m, MonadIO m, MonadMask m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, HasTerminal env)@@ -439,7 +450,8 @@ -> m BuildConfig loadBuildConfig mproject config mresolver mcompiler = do env <- ask- miniConfig <- loadMiniConfig config+ manager <- getHttpManager <$> ask+ miniConfig <- loadMiniConfig manager config (project', stackYamlFP) <- case mproject of Just (project, fp, _) -> do@@ -512,24 +524,18 @@ , projectCompiler = mcompiler <|> projectCompiler project' } - wantedCompiler <-- case projectCompiler project of- Just wantedCompiler -> return wantedCompiler- Nothing -> case projectResolver project of- ResolverSnapshot snapName -> do- mbp <- runReaderT (loadMiniBuildPlan snapName) miniConfig- return $ mbpCompilerVersion mbp- ResolverCustom _name url -> do- mbp <- runReaderT (parseCustomMiniBuildPlan stackYamlFP url) miniConfig- return $ mbpCompilerVersion mbp- ResolverCompiler wantedCompiler -> return wantedCompiler+ (mbp0, loadedResolver) <- flip runReaderT miniConfig $+ loadResolver (Just stackYamlFP) (projectResolver project)+ let mbp = case projectCompiler project of+ Just compiler -> mbp0 { mbpCompilerVersion = compiler }+ Nothing -> mbp0 extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) return BuildConfig { bcConfig = config- , bcResolver = projectResolver project- , bcWantedCompiler = wantedCompiler+ , bcResolver = loadedResolver+ , bcWantedMiniBuildPlan = mbp , bcPackageEntries = projectPackages project , bcExtraDeps = projectExtraDeps project , bcExtraPackageDBs = extraPackageDBs@@ -542,7 +548,7 @@ -- | Resolve a PackageEntry into a list of paths, downloading and cloning as -- necessary. resolvePackageEntry- :: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m+ :: (MonadIO m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m ,MonadBaseControl IO m, HasConfig env) => EnvOverride -> Path Abs Dir -- ^ project root@@ -559,7 +565,7 @@ -- | Resolve a PackageLocation into a path, downloading and cloning as -- necessary. resolvePackageLocation- :: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m+ :: (MonadIO m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m ,MonadBaseControl IO m, HasConfig env) => EnvOverride -> Path Abs Dir -- ^ project root@@ -567,12 +573,17 @@ -> m (Path Abs Dir) resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do+ -- NOTE: we used to include the commit in the package location. This+ -- allowed us to quickly check if the dir exists, and use it if it+ -- does. Now, we instead always do a reset. This is still pretty+ -- fast - a no-op git reset is around 0.01 seconds on my machine. workDir <- getWorkDir let nameBeforeHashing = case remotePackageType of- RPTHttp -> url- RPTGit commit -> T.unwords [url, commit]- RPTHg commit -> T.unwords [url, commit, "hg"]- name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 nameBeforeHashing+ RPTHttp{} -> url+ RPTGit{} -> url+ RPTHg{} -> T.unwords [url, "hg"]+ -- TODO: dedupe with code for snapshot hash?+ name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ SHA256.hash $ encodeUtf8 nameBeforeHashing root = projRoot </> workDir </> $(mkRelDir "downloaded") fileExtension = case remotePackageType of RPTHttp -> ".http-archive"@@ -583,28 +594,40 @@ dirRelTmp <- parseRelDir $ name ++ ".tmp" let file = root </> fileRel dir = root </> dirRel- dirTmp = root </> dirRelTmp exists <- doesDirExist dir- unless exists $ do- ignoringAbsence (removeDirRecur dirTmp)-- let cloneAndExtract commandName cloneArgs resetCommand commit = do- ensureDir (parent dirTmp)- readInNull (parent dirTmp) commandName menv+ let cloneAndExtract commandName cloneArgs resetCommand commit = do+ ensureDir (parent dir)+ (if exists then doReset True else doClone >> doReset True) `catch` \case+ ReadProcessException{} -> do+ ignoringAbsence (removeDirRecur dir)+ doClone+ doReset False+ _ -> return ()+ return dir+ where+ doClone =+ readProcessNull (Just (parent dir)) menv commandName ("clone" : cloneArgs ++ [ T.unpack url- , toFilePathNoTrailingSep dirTmp+ , toFilePathNoTrailingSep dir ])- Nothing- readInNull dirTmp commandName menv+ doReset firstTry =+ readProcessNull (Just dir) menv commandName (resetCommand ++ [T.unpack commit, "--"])- (Just $ "Please ensure that commit " <> commit <>- " exists within " <> url)+ `catch` \case+ ex@ReadProcessException{} -> do+ unless firstTry $ $logInfo $+ "Please ensure that commit " <> commit <> " exists within " <> url+ throwM ex+ ex -> throwM ex+ case remotePackageType of+ RPTHttp -> do+ unless exists $ do+ let dirTmp = root </> dirRelTmp+ ignoringAbsence (removeDirRecur dirTmp) - case remotePackageType of- RPTHttp -> do let fp = toFilePath file req <- parseUrl $ T.unpack url _ <- download req file@@ -628,21 +651,17 @@ handler tryTar `catchAllLog` tryZip `catchAllLog` err-- RPTGit commit -> cloneAndExtract "git" ["--recursive"] ["reset", "--hard"] commit- RPTHg commit -> cloneAndExtract "hg" [] ["update", "-C"] commit-- renameDir dirTmp dir+ renameDir dirTmp dir+ x <- listDir dir+ case x of+ ([dir'], []) -> return dir'+ (dirs, files) -> do+ ignoringAbsence (removeFile file)+ ignoringAbsence (removeDirRecur dir)+ throwM $ UnexpectedArchiveContents dirs files - case remotePackageType of- RPTHttp -> do x <- listDir dir- case x of- ([dir'], []) -> return dir'- (dirs, files) -> do- ignoringAbsence (removeFile file)- ignoringAbsence (removeDirRecur dir)- throwM $ UnexpectedArchiveContents dirs files- _ -> return dir+ RPTGit commit -> cloneAndExtract "git" ["--recursive"] ["reset", "--hard"] commit+ RPTHg commit -> cloneAndExtract "hg" [] ["update", "-C"] commit -- | Get the stack root, e.g. @~/.stack@, and determine whether the user owns it. --@@ -654,7 +673,7 @@ -> m (Path Abs Dir, Bool) determineStackRootAndOwnership clArgs = do stackRoot <- do- case configMonoidStackRoot clArgs of+ case getFirst (configMonoidStackRoot clArgs) of Just x -> return x Nothing -> do mstackRoot <- liftIO $ lookupEnv stackRootEnvVar
src/Stack/Config/Build.hs view
@@ -3,66 +3,73 @@ -- | Build configuration module Stack.Config.Build where -import Data.Maybe (fromMaybe)+import Data.Monoid.Extra import Stack.Types -- | Interprets BuildOptsMonoid options. buildOptsFromMonoid :: BuildOptsMonoid -> BuildOpts buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts- { boptsLibProfile = fromMaybe+ { boptsLibProfile = fromFirst (boptsLibProfile defaultBuildOpts) buildMonoidLibProfile- , boptsExeProfile = fromMaybe+ , boptsExeProfile = fromFirst (boptsExeProfile defaultBuildOpts) buildMonoidExeProfile- , boptsHaddock = fromMaybe+ , boptsHaddock = fromFirst (boptsHaddock defaultBuildOpts) buildMonoidHaddock- , boptsOpenHaddocks = fromMaybe+ , boptsHaddockOpts = haddockOptsFromMonoid buildMonoidHaddockOpts+ , boptsOpenHaddocks = fromFirst (boptsOpenHaddocks defaultBuildOpts) buildMonoidOpenHaddocks- , boptsHaddockDeps = buildMonoidHaddockDeps- , boptsInstallExes = fromMaybe+ , boptsHaddockDeps = getFirst buildMonoidHaddockDeps+ , boptsInstallExes = fromFirst (boptsInstallExes defaultBuildOpts) buildMonoidInstallExes- , boptsPreFetch = fromMaybe+ , boptsPreFetch = fromFirst (boptsPreFetch defaultBuildOpts) buildMonoidPreFetch- , boptsKeepGoing = buildMonoidKeepGoing- , boptsForceDirty = fromMaybe+ , boptsKeepGoing = getFirst buildMonoidKeepGoing+ , boptsForceDirty = fromFirst (boptsForceDirty defaultBuildOpts) buildMonoidForceDirty- , boptsTests = fromMaybe (boptsTests defaultBuildOpts) buildMonoidTests+ , boptsTests = fromFirst (boptsTests defaultBuildOpts) buildMonoidTests , boptsTestOpts = testOptsFromMonoid buildMonoidTestOpts- , boptsBenchmarks = fromMaybe+ , boptsBenchmarks = fromFirst (boptsBenchmarks defaultBuildOpts) buildMonoidBenchmarks , boptsBenchmarkOpts = benchmarkOptsFromMonoid buildMonoidBenchmarkOpts- , boptsReconfigure = fromMaybe+ , boptsReconfigure = fromFirst (boptsReconfigure defaultBuildOpts) buildMonoidReconfigure- , boptsCabalVerbose = fromMaybe+ , boptsCabalVerbose = fromFirst (boptsCabalVerbose defaultBuildOpts) buildMonoidCabalVerbose- , boptsSplitObjs = fromMaybe+ , boptsSplitObjs = fromFirst (boptsSplitObjs defaultBuildOpts) buildMonoidSplitObjs } ++haddockOptsFromMonoid :: HaddockOptsMonoid -> HaddockOpts+haddockOptsFromMonoid HaddockOptsMonoid{..} =+ defaultHaddockOpts+ {toHaddockArgs = toMonoidHaddockArgs}+ testOptsFromMonoid :: TestOptsMonoid -> TestOpts testOptsFromMonoid TestOptsMonoid{..} = defaultTestOpts- { toRerunTests = fromMaybe (toRerunTests defaultTestOpts) toMonoidRerunTests+ { toRerunTests = fromFirst (toRerunTests defaultTestOpts) toMonoidRerunTests , toAdditionalArgs = toMonoidAdditionalArgs- , toCoverage = fromMaybe (toCoverage defaultTestOpts) toMonoidCoverage- , toDisableRun = fromMaybe (toDisableRun defaultTestOpts) toMonoidDisableRun+ , toCoverage = fromFirst (toCoverage defaultTestOpts) toMonoidCoverage+ , toDisableRun = fromFirst (toDisableRun defaultTestOpts) toMonoidDisableRun } benchmarkOptsFromMonoid :: BenchmarkOptsMonoid -> BenchmarkOpts benchmarkOptsFromMonoid BenchmarkOptsMonoid{..} = defaultBenchmarkOpts- { beoAdditionalArgs = beoMonoidAdditionalArgs- , beoDisableRun = fromMaybe+ { beoAdditionalArgs = getFirst beoMonoidAdditionalArgs+ , beoDisableRun = fromFirst (beoDisableRun defaultBenchmarkOpts) beoMonoidDisableRun }
src/Stack/Config/Docker.hs view
@@ -8,6 +8,7 @@ import Control.Monad.Catch (throwM, MonadThrow) import Data.List (find) import Data.Maybe+import Data.Monoid.Extra import qualified Data.Text as T import Data.Typeable (Typeable) import Distribution.Version (simplifyVersionRange)@@ -24,7 +25,7 @@ -> m DockerOpts dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do let dockerEnable =- fromMaybe dockerMonoidDefaultEnable dockerMonoidEnable+ fromFirst (getAny dockerMonoidDefaultEnable) dockerMonoidEnable dockerImage = let mresolver = case maresolver of@@ -47,7 +48,7 @@ throw (ResolverNotSupportedException $ show resolver)- in case dockerMonoidRepoOrImage of+ in case getFirst dockerMonoidRepoOrImage of Nothing -> "fpco/stack-build" ++ defaultTag Just (DockerMonoidImage image) -> image Just (DockerMonoidRepo repo) ->@@ -57,29 +58,30 @@ repo Nothing -> repo ++ defaultTag dockerRegistryLogin =- fromMaybe- (isJust (emptyToNothing dockerMonoidRegistryUsername))+ fromFirst+ (isJust (emptyToNothing (getFirst dockerMonoidRegistryUsername))) dockerMonoidRegistryLogin- dockerRegistryUsername = emptyToNothing dockerMonoidRegistryUsername- dockerRegistryPassword = emptyToNothing dockerMonoidRegistryPassword- dockerAutoPull = fromMaybe False dockerMonoidAutoPull- dockerDetach = fromMaybe False dockerMonoidDetach- dockerPersist = fromMaybe False dockerMonoidPersist- dockerContainerName = emptyToNothing dockerMonoidContainerName+ dockerRegistryUsername = emptyToNothing (getFirst dockerMonoidRegistryUsername)+ dockerRegistryPassword = emptyToNothing (getFirst dockerMonoidRegistryPassword)+ dockerAutoPull = fromFirst False dockerMonoidAutoPull+ dockerDetach = fromFirst False dockerMonoidDetach+ dockerPersist = fromFirst False dockerMonoidPersist+ dockerContainerName = emptyToNothing (getFirst dockerMonoidContainerName) dockerRunArgs = dockerMonoidRunArgs dockerMount = dockerMonoidMount dockerEnv = dockerMonoidEnv- dockerSetUser = dockerMonoidSetUser- dockerRequireDockerVersion = simplifyVersionRange dockerMonoidRequireDockerVersion+ dockerSetUser = getFirst dockerMonoidSetUser+ dockerRequireDockerVersion =+ simplifyVersionRange (getIntersectingVersionRange dockerMonoidRequireDockerVersion) dockerDatabasePath <-- case dockerMonoidDatabasePath of+ case getFirst dockerMonoidDatabasePath of Nothing -> return $ stackRoot </> $(mkRelFile "docker.db") Just fp -> case parseAbsFile fp of Left e -> throwM (InvalidDatabasePathException e) Right p -> return p dockerStackExe <-- case dockerMonoidStackExe of+ case getFirst dockerMonoidStackExe of Just e -> liftM Just (parseDockerStackExe e) Nothing -> return Nothing return DockerOpts{..}
src/Stack/Config/Nix.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, OverloadedStrings #-} -- | Nix configuration module Stack.Config.Nix@@ -9,8 +9,9 @@ import Control.Applicative import Control.Monad (join, when)-import qualified Data.Text as T import Data.Maybe+import Data.Monoid.Extra+import qualified Data.Text as T import Data.Typeable import Distribution.System (OS (..)) import Stack.Types@@ -25,15 +26,15 @@ -> OS -> m NixOpts nixOptsFromMonoid NixOptsMonoid{..} os = do- let nixEnable = fromMaybe nixMonoidDefaultEnable nixMonoidEnable+ let nixEnable = fromFirst (getAny nixMonoidDefaultEnable) nixMonoidEnable defaultPure = case os of OSX -> False _ -> True- nixPureShell = fromMaybe defaultPure nixMonoidPureShell- nixPackages = fromMaybe [] nixMonoidPackages- nixInitFile = nixMonoidInitFile- nixShellOptions = fromMaybe [] nixMonoidShellOptions- ++ prefixAll (T.pack "-I") (fromMaybe [] nixMonoidPath)+ nixPureShell = fromFirst defaultPure nixMonoidPureShell+ nixPackages = fromFirst [] nixMonoidPackages+ nixInitFile = getFirst nixMonoidInitFile+ nixShellOptions = fromFirst [] nixMonoidShellOptions+ ++ prefixAll (T.pack "-I") (fromFirst [] nixMonoidPath) when (not (null nixPackages) && isJust nixInitFile) $ throwM NixCannotUseShellFileAndPackagesException return NixOpts{..}@@ -45,7 +46,18 @@ let mproject = fst <$> configMaybeProject config mresolver = resolverOverride <|> fmap projectResolver mproject mcompiler = compilerOverride <|> join (fmap projectCompiler mproject)- nixCompilerFromVersion v = T.filter (/= '.') $ T.append (T.pack "haskell.compiler.ghc") (versionText v)++ -- These are the latest minor versions for each respective major version available in nixpkgs+ fixMinor "8.0" = "8.0.1"+ fixMinor "7.10" = "7.10.3"+ fixMinor "7.8" = "7.8.4"+ fixMinor "7.6" = "7.6.3"+ fixMinor "7.4" = "7.4.2"+ fixMinor "7.2" = "7.2.2"+ fixMinor "6.12" = "6.12.3"+ fixMinor "6.10" = "6.10.4"+ fixMinor v = v+ nixCompilerFromVersion v = T.append (T.pack "haskell.compiler.ghc") (T.filter (/= '.') (fixMinor (versionText v))) in case (mresolver, mcompiler) of (_, Just (GhcVersion v)) -> nixCompilerFromVersion v (Just (ResolverCompiler (GhcVersion v)), _) -> nixCompilerFromVersion v
src/Stack/Config/Urls.hs view
@@ -3,14 +3,14 @@ module Stack.Config.Urls (urlsFromMonoid) where import Stack.Types-import Data.Maybe+import Data.Monoid.Extra urlsFromMonoid :: UrlsMonoid -> Urls urlsFromMonoid monoid = Urls- (fromMaybe defaultLatestSnapshot $ urlsMonoidLatestSnapshot monoid)- (fromMaybe defaultLtsBuildPlans $ urlsMonoidLtsBuildPlans monoid)- (fromMaybe defaultNightlyBuildPlans $ urlsMonoidNightlyBuildPlans monoid)+ (fromFirst defaultLatestSnapshot $ urlsMonoidLatestSnapshot monoid)+ (fromFirst defaultLtsBuildPlans $ urlsMonoidLtsBuildPlans monoid)+ (fromFirst defaultNightlyBuildPlans $ urlsMonoidNightlyBuildPlans monoid) where defaultLatestSnapshot = "https://www.stackage.org/download/snapshots.json"
src/Stack/ConfigCmd.hs view
@@ -10,7 +10,7 @@ ,cfgCmdSetName ,cfgCmdName) where -import Control.Monad.Catch (MonadMask, throwM, MonadThrow)+import Control.Monad.Catch (MonadMask, throwM) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (MonadReader, asks)@@ -30,11 +30,9 @@ , MonadBaseControl IO m , MonadMask m , MonadReader env m- , HasConfig env , HasBuildConfig env , HasHttpManager env , HasGHCVariant env- , MonadThrow m , MonadLogger m) => ConfigCmdSet -> m () cfgCmdSet (ConfigCmdSetResolver newResolver) = do@@ -45,6 +43,7 @@ (projectYamlConfig :: Yaml.Object) <- liftIO (Yaml.decodeFileEither stackYamlFp) >>= either throwM return+ -- TODO: custom snapshot support? newResolverText <- fmap resolverName (makeConcreteResolver newResolver) -- We checking here that the snapshot actually exists snap <- parseSnapName newResolverText
src/Stack/Constants.hs view
@@ -73,7 +73,7 @@ return (bcwd </> $(mkRelDir "odir/")) -- | The filename used for dirtiness check of source files.-buildCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+buildCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => Path Abs Dir -- ^ Package directory. -> m (Path Abs File) buildCacheFile dir =@@ -82,7 +82,7 @@ (distDirFromDir dir) -- | The filename used to mark tests as having succeeded-testSuccessFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+testSuccessFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => Path Abs Dir -- ^ Package directory -> m (Path Abs File) testSuccessFile dir =@@ -91,7 +91,7 @@ (distDirFromDir dir) -- | The filename used to mark tests as having built-testBuiltFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+testBuiltFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => Path Abs Dir -- ^ Package directory -> m (Path Abs File) testBuiltFile dir =@@ -100,7 +100,7 @@ (distDirFromDir dir) -- | The filename used for dirtiness check of config.-configCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+configCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => Path Abs Dir -- ^ Package directory. -> m (Path Abs File) configCacheFile dir =@@ -109,7 +109,7 @@ (distDirFromDir dir) -- | The filename used for modification check of .cabal-configCabalMod :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+configCabalMod :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => Path Abs Dir -- ^ Package directory. -> m (Path Abs File) configCabalMod dir =@@ -119,27 +119,27 @@ -- | Directory for HPC work. hpcDirFromDir- :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)+ :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => Path Abs Dir -- ^ Package directory. -> m (Path Abs Dir) hpcDirFromDir fp = liftM (fp </>) hpcRelativeDir -- | Relative location of directory for HPC work.-hpcRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)+hpcRelativeDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir) hpcRelativeDir = liftM (</> $(mkRelDir "hpc")) distRelativeDir -- | Package's build artifacts directory.-distDirFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)+distDirFromDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => Path Abs Dir -> m (Path Abs Dir) distDirFromDir fp = liftM (fp </>) distRelativeDir -- | Package's working directory.-workDirFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)+workDirFromDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => Path Abs Dir -> m (Path Abs Dir) workDirFromDir fp =@@ -150,7 +150,7 @@ templatesDir config = configStackRoot config </> $(mkRelDir "templates") -- | Relative location of build artifacts.-distRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)+distRelativeDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir) distRelativeDir = do cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)
src/Stack/Coverage.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} -- | Generate HPC (Haskell Program Coverage) reports module Stack.Coverage ( deleteHpcReports@@ -18,7 +19,7 @@ import Control.Applicative import Control.Exception.Lifted import Control.Monad (liftM, when, unless, void)-import Control.Monad.Catch (MonadCatch)+import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (MonadReader, asks)@@ -37,7 +38,6 @@ import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT import Data.Traversable (forM)-import Network.HTTP.Download (HasHttpManager) import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO@@ -53,7 +53,7 @@ import Trace.Hpc.Tix -- | Invoked at the beginning of running with "--coverage"-deleteHpcReports :: (MonadIO m, MonadCatch m, MonadReader env m, HasEnvConfig env)+deleteHpcReports :: (MonadIO m, MonadMask m, MonadReader env m, HasEnvConfig env) => m () deleteHpcReports = do hpcDir <- hpcReportDir@@ -61,7 +61,7 @@ -- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is -- present.-updateTixFile :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)+updateTixFile :: (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env) => PackageName -> Path Abs File -> String -> m () updateTixFile pkgName tixSrc testName = do exists <- doesFileExist tixSrc@@ -79,7 +79,7 @@ ignoringAbsence (removeFile tixSrc) -- | Get the directory used for hpc reports for the given pkgId.-hpcPkgPath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)+hpcPkgPath :: (MonadIO m,MonadReader env m,MonadMask m,HasEnvConfig env) => PackageName -> m (Path Abs Dir) hpcPkgPath pkgName = do outputDir <- hpcReportDir@@ -88,7 +88,7 @@ -- | Get the tix file location, given the name of the file (without extension), and the package -- identifier string.-tixFilePath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)+tixFilePath :: (MonadIO m,MonadReader env m,MonadMask m,HasEnvConfig env) => PackageName -> String -> m (Path Abs File) tixFilePath pkgName testName = do pkgPath <- hpcPkgPath pkgName@@ -96,7 +96,7 @@ return (pkgPath </> tixRel) -- | Generates the HTML coverage report and shows a textual coverage summary for a package.-generateHpcReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)+generateHpcReport :: (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env) => Path Abs Dir -> Package -> [Text] -> m () generateHpcReport pkgDir package tests = do -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See@@ -133,7 +133,7 @@ Nothing -> [] generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs -generateHpcReportInternal :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)+generateHpcReportInternal :: (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env) => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String] -> m () generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArgs = do -- If a .tix file exists, move it to the HPC output directory and generate a report for it.@@ -204,7 +204,7 @@ , hroptsDestDir :: Maybe String } deriving (Show) -generateHpcReportForTargets :: (MonadIO m, HasHttpManager env, MonadReader env m, MonadBaseControl IO m, MonadCatch m, MonadLogger m, HasEnvConfig env)+generateHpcReportForTargets :: (MonadIO m, MonadReader env m, MonadBaseControl IO m, MonadMask m, MonadLogger m, HasEnvConfig env) => HpcReportOpts -> m () generateHpcReportForTargets opts = do let (tixFiles, targetNames) = partition (".tix" `T.isSuffixOf`) (hroptsInputs opts)@@ -257,7 +257,7 @@ return dest generateUnionReport "combined report" reportDir tixPaths -generateHpcUnifiedReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)+generateHpcUnifiedReport :: (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env) => m () generateHpcUnifiedReport = do outputDir <- hpcReportDir@@ -278,7 +278,7 @@ ] else generateUnionReport "unified report" reportDir tixFiles -generateUnionReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)+generateUnionReport :: (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env) => Text -> Path Abs Dir -> [Path Abs File] -> m () generateUnionReport report reportDir tixFiles = do (errs, tix) <- fmap (unionTixes . map removeExeModules) (mapMaybeM readTixOrLog tixFiles)@@ -293,8 +293,8 @@ readTixOrLog :: (MonadLogger m, MonadIO m, MonadBaseControl IO m) => Path b File -> m (Maybe Tix) readTixOrLog path = do- mtix <- liftIO (readTix (toFilePath path)) `catch` \(ErrorCall err) -> do- $logError $ "Error while reading tix: " <> T.pack err+ mtix <- liftIO (readTix (toFilePath path)) `catch` \errorCall -> do+ $logError $ "Error while reading tix: " <> T.pack (show (errorCall :: ErrorCall)) return Nothing when (isNothing mtix) $ $logError $ "Failed to read tix file " <> T.pack (toFilePath path)@@ -315,7 +315,7 @@ | hash1 == hash2 && len1 == len2 = Right (TixModule k hash1 len1 (zipWith (+) tix1 tix2)) merge _ _ = Left () -generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadCatch m,HasEnvConfig env)+generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadMask m,HasEnvConfig env) => m () generateHpcMarkupIndex = do outputDir <- hpcReportDir
src/Stack/Docker.hs view
@@ -640,7 +640,7 @@ containerStr = "container" -- | Inspect Docker image or container.-inspect :: (MonadIO m,MonadThrow m,MonadLogger m,MonadBaseControl IO m,MonadCatch m)+inspect :: (MonadIO m,MonadLogger m,MonadBaseControl IO m,MonadCatch m) => EnvOverride -> String -> m (Maybe Inspect) inspect envOverride image = do results <- inspects envOverride [image]@@ -650,7 +650,7 @@ _ -> throwM (InvalidInspectOutputException "expect a single result") -- | Inspect multiple Docker images and/or containers.-inspects :: (MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+inspects :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> [String] -> m (Map String Inspect) inspects _ [] = return Map.empty inspects envOverride images =@@ -698,7 +698,7 @@ -- | Check docker version (throws exception if incorrect) checkDockerVersion- :: (MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> DockerOpts -> m () checkDockerVersion envOverride docker = do dockerExists <- doesExecutableExist envOverride "docker"
src/Stack/Dot.hs view
@@ -16,7 +16,7 @@ import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader (MonadReader)-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.Foldable as F import qualified Data.HashSet as HashSet import Data.Map (Map)@@ -55,7 +55,7 @@ dot :: (HasEnvConfig env ,HasHttpManager env ,HasLogLevel env- ,MonadBaseControl IO m+ ,MonadBaseUnlift IO m ,MonadCatch m ,MonadLogger m ,MonadIO m@@ -81,8 +81,7 @@ ,HasHttpManager env ,HasLogLevel env ,MonadLogger m- ,MonadBaseControl IO m- ,MonadCatch m+ ,MonadBaseUnlift IO m ,MonadIO m ,MonadMask m ,MonadReader env m)@@ -99,11 +98,11 @@ let depLoader = createDepLoader sourceMap installedMap- (fmap3 (packageAllDeps &&& (Just . packageVersion)) loader)+ (fmap4 (packageAllDeps &&& (Just . packageVersion)) loader) liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader) where -- fmap a function over the result of a function with 3 arguments- fmap3 :: Functor f => (d -> e) -> (a -> b -> c -> f d) -> a -> b -> c -> f e- fmap3 f g a b c = f <$> g a b c+ fmap4 :: Functor f => (r -> r') -> (a -> b -> c -> d -> f r) -> a -> b -> c -> d -> f r'+ fmap4 f g a b c d = f <$> g a b c d fst4 :: (a,b,c,d) -> a fst4 (x,_,_,_) = x@@ -111,8 +110,7 @@ listDependencies :: (HasEnvConfig env ,HasHttpManager env ,HasLogLevel env- ,MonadBaseControl IO m- ,MonadCatch m+ ,MonadBaseUnlift IO m ,MonadLogger m ,MonadMask m ,MonadIO m@@ -183,13 +181,13 @@ createDepLoader :: Applicative m => Map PackageName PackageSource -> Map PackageName Installed- -> (PackageName -> Version -> Map FlagName Bool -> m (Set PackageName,Maybe Version))+ -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> m (Set PackageName,Maybe Version)) -> PackageName -> m (Set PackageName, Maybe Version) createDepLoader sourceMap installed loadPackageDeps pkgName = case Map.lookup pkgName sourceMap of Just (PSLocal lp) -> pure ((packageAllDeps &&& (Just . packageVersion)) (lpPackage lp))- Just (PSUpstream version _ flags) -> loadPackageDeps pkgName version flags+ Just (PSUpstream version _ flags ghcOptions _) -> loadPackageDeps pkgName version flags ghcOptions Nothing -> pure (Set.empty, fmap installedVersion (Map.lookup pkgName installed)) -- | Resolve the direct (depth 0) external dependencies of the given local packages@@ -232,14 +230,14 @@ lpNodes = map (applyStyle . nodeName) (F.toList locals) -- | Print nodes without dependencies-printLeaves :: (Applicative m, MonadIO m)+printLeaves :: MonadIO m => Map PackageName (Set PackageName,Maybe Version) -> m ()-printLeaves = F.traverse_ printLeaf . Map.keysSet . Map.filter Set.null . fmap fst+printLeaves = F.mapM_ printLeaf . Map.keysSet . Map.filter Set.null . fmap fst -- | @printDedges p ps@ prints an edge from p to every ps-printEdges :: (Applicative m, MonadIO m) => PackageName -> Set PackageName -> m ()-printEdges package deps = F.for_ deps (printEdge package)+printEdges :: MonadIO m => PackageName -> Set PackageName -> m ()+printEdges package deps = F.forM_ deps (printEdge package) -- | Print an edge between the two package names printEdge :: MonadIO m => PackageName -> PackageName -> m ()
src/Stack/Exec.hs view
@@ -3,6 +3,10 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif+ -- | Execute commands within the properly configured Stack -- environment. @@ -10,7 +14,6 @@ import Control.Monad.Reader import Control.Monad.Logger-import Control.Monad.Catch hiding (try) import Control.Monad.Trans.Control (MonadBaseControl) import Stack.Types import System.Process.Log@@ -52,7 +55,7 @@ -- sub-process. This allows signals to be propagated (#527) -- -- 2) On windows, an 'ExitCode' exception will be thrown.-exec :: (MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m)+exec :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) => EnvOverride -> String -> [String] -> m b #ifdef WINDOWS exec = execSpawn@@ -67,7 +70,7 @@ -- is a sub-process, which is helpful in some cases (#1306) -- -- This function only exits by throwing 'ExitCode'.-execSpawn :: (MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m)+execSpawn :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) => EnvOverride -> String -> [String] -> m b execSpawn menv cmd0 args = do $logProcessRun cmd0 args
src/Stack/Fetch.hs view
@@ -34,6 +34,7 @@ newTVarIO, readTVar, readTVarIO, writeTVar) import Control.Exception (assert)+import Control.Exception.Enclosed (tryIO) import Control.Monad (join, liftM, unless, void, when) import Control.Monad.Catch@@ -41,6 +42,7 @@ import Control.Monad.Logger import Control.Monad.Reader (asks, runReaderT) import Control.Monad.Trans.Control+import Control.Monad.Trans.Unlift (MonadBaseUnlift, askRunBase) import "cryptohash" Crypto.Hash (SHA512 (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as S@@ -48,15 +50,20 @@ import Data.Either (partitionEithers) import qualified Data.Foldable as F import Data.Function (fix)+import qualified Data.Git as Git+import qualified Data.Git.Ref as Git+import qualified Data.Git.Storage as Git+import qualified Data.Git.Storage.Object as Git import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (maybeToList, catMaybes)-import Data.Monoid ((<>))+import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set+import Data.String (fromString) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Typeable (Typeable)@@ -73,7 +80,8 @@ import qualified System.FilePath as FP import System.IO (IOMode (ReadMode), SeekMode (AbsoluteSeek), hSeek,- withBinaryFile)+ withBinaryFile, openBinaryFile,+ hClose) import System.PosixCompat (setFileMode) import Text.EditDistance as ED @@ -117,19 +125,23 @@ (if null suggestions then "" else "\n" ++ suggestions) -- | Fetch packages into the cache without unpacking-fetchPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m)+fetchPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadMask m, MonadLogger m) => EnvOverride -> Set PackageIdentifier -> m ()-fetchPackages menv idents = do+fetchPackages menv idents' = do resolved <- resolvePackages menv 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 Nothing Git SHA+ idents = Map.fromList $ map (, Nothing) $ Set.toList idents' -- | Intended to work for the command line command.-unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m)+unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadMask m, MonadLogger m) => EnvOverride -> FilePath -- ^ destination -> [String] -- ^ names or identifiers@@ -139,7 +151,9 @@ (names, idents) <- case partitionEithers $ map parse input of ([], x) -> return $ partitionEithers x (errs, _) -> throwM $ CouldNotParsePackageSelectors errs- resolved <- resolvePackages menv (Set.fromList idents) (Set.fromList names)+ resolved <- resolvePackages menv+ (Map.fromList $ map (, Nothing) idents)+ (Set.fromList names) ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved unless (Map.null alreadyUnpacked) $ throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked@@ -163,11 +177,11 @@ -- | Ensure that all of the given package idents are unpacked into the build -- unpack directory, and return the paths to all of the subdirectories. unpackPackageIdents- :: (MonadBaseControl IO m, MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m)+ :: (MonadBaseControl IO m, MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadMask m, MonadLogger m) => EnvOverride -> Path Abs Dir -- ^ unpack directory -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157- -> Set PackageIdentifier+ -> Map PackageIdentifier (Maybe GitSHA1) -> m (Map PackageIdentifier (Path Abs Dir)) unpackPackageIdents menv unpackDir mdistDir idents = do resolved <- resolvePackages menv idents Set.empty@@ -178,12 +192,13 @@ data ResolvedPackage = ResolvedPackage { rpCache :: !PackageCache , rpIndex :: !PackageIndex+ , rpGitSHA1 :: !(Maybe GitSHA1) } -- | Resolve a set of package names and identifiers into @FetchPackage@ values. resolvePackages :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride- -> Set PackageIdentifier+ -> Map PackageIdentifier (Maybe GitSHA1) -> Set PackageName -> m (Map PackageIdentifier ResolvedPackage) resolvePackages menv idents0 names0 = do@@ -201,8 +216,8 @@ | otherwise = Right idents resolvePackagesAllowMissing- :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadThrow m, MonadBaseControl IO m, MonadCatch m)- => Set PackageIdentifier+ :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+ => Map PackageIdentifier (Maybe GitSHA1) -> Set PackageName -> m (Set PackageName, Set PackageIdentifier, Map PackageIdentifier ResolvedPackage) resolvePackagesAllowMissing idents0 names0 = do@@ -213,16 +228,17 @@ (Map.lookup name versions)) (Set.toList names0) (missingIdents, resolved) = partitionEithers $ map (goIdent caches)- $ Set.toList- $ idents0 <> Set.fromList idents1+ $ Map.toList+ $ idents0 <> Map.fromList (map (, Nothing) idents1) return (Set.fromList missingNames, Set.fromList missingIdents, Map.fromList resolved) where- goIdent caches ident =+ goIdent caches (ident, mgitsha) = case Map.lookup ident caches of Nothing -> Left ident Just (index, cache) -> Right (ident, ResolvedPackage { rpCache = cache , rpIndex = index+ , rpGitSHA1 = mgitsha }) data ToFetch = ToFetch@@ -242,17 +258,44 @@ -- | Add the cabal files to a list of idents with their caches. withCabalFiles- :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env)+ :: (MonadMask m, MonadIO m, MonadLogger m, MonadReader env m, HasConfig env) => IndexName- -> [(PackageIdentifier, PackageCache, a)]+ -> [(PackageIdentifier, PackageCache, Maybe GitSHA1, a)] -> (PackageIdentifier -> a -> ByteString -> IO b) -> m [b] withCabalFiles name pkgs f = do indexPath <- configPackageIndex name- liftIO $ withBinaryFile (toFilePath indexPath) ReadMode $ \h ->- mapM (goPkg h) pkgs+ mgitRepo <- configPackageIndexRepo name+ bracket+ (liftIO $ openBinaryFile (toFilePath indexPath) ReadMode)+ (liftIO . hClose) $ \h ->+ let inner mgit = mapM (goPkg h mgit) pkgs+ in case mgitRepo of+ Nothing -> inner Nothing+ Just repo -> bracket+ (liftIO $ Git.openRepo+ $ fromString+ $ toFilePath repo FP.</> ".git")+ (liftIO . Git.closeRepo)+ (inner . Just) where- goPkg h (ident, pc, tf) = do+ goPkg h (Just git) (ident, pc, Just (GitSHA1 sha), tf) = do+ let ref = Git.fromHex sha+ mobj <- liftIO $ tryIO $ Git.getObject git ref True+ case mobj of+ Right (Just (Git.ObjBlob (Git.Blob bs))) -> liftIO $ f ident tf (L.toStrict bs)+ -- fallback when the appropriate SHA isn't found+ e -> do+ $logWarn $ mconcat+ [ "Did not find .cabal file for "+ , T.pack $ packageIdentifierString ident+ , " with Git SHA of "+ , decodeUtf8 sha+ , "\n"+ , T.pack $ show e+ ]+ goPkg h Nothing (ident, pc, Nothing, tf)+ goPkg h _mgit (ident, pc, _mgitsha, tf) = liftIO $ do hSeek h AbsoluteSeek $ fromIntegral $ pcOffset pc cabalBS <- S.hGet h $ fromIntegral $ pcSize pc f ident tf cabalBS@@ -260,7 +303,7 @@ -- | Provide a function which will load up a cabal @ByteString@ from the -- package indices. withCabalLoader- :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)+ :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env, MonadBaseUnlift IO m, MonadMask m) => EnvOverride -> ((PackageIdentifier -> IO ByteString) -> m a) -> m a@@ -276,13 +319,14 @@ loadCaches <- getPackageCachesIO runInBase <- liftBaseWith $ \run -> return (void . run)+ unlift <- askRunBase -- TODO in the future, keep all of the necessary @Handle@s open let doLookup :: PackageIdentifier -> IO ByteString doLookup ident = do caches <- loadCaches- eres <- lookupPackageIdentifierExact ident env caches+ eres <- unlift $ lookupPackageIdentifierExact ident env caches case eres of Just bs -> return bs -- Update the cache and try again@@ -316,17 +360,17 @@ inner doLookup lookupPackageIdentifierExact- :: HasConfig env+ :: (MonadMask m, MonadIO m, MonadLogger m, HasConfig env) => PackageIdentifier -> env -> PackageCaches- -> IO (Maybe ByteString)+ -> m (Maybe ByteString) lookupPackageIdentifierExact ident env caches = case Map.lookup ident caches of Nothing -> return Nothing Just (index, cache) -> do [bs] <- flip runReaderT env- $ withCabalFiles (indexName index) [(ident, cache, ())]+ $ withCabalFiles (indexName index) [(ident, cache, Nothing, ())] $ \_ _ bs -> return bs return $ Just bs @@ -361,7 +405,7 @@ . Map.mapKeys getName -- | Figure out where to fetch from.-getToFetch :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env)+getToFetch :: (MonadMask m, MonadLogger m, MonadIO m, MonadReader env m, HasConfig env) => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack -> Map PackageIdentifier ResolvedPackage -> m ToFetchResult@@ -389,7 +433,7 @@ d = pcDownload $ rpCache resolved targz = T.pack $ packageIdentifierString ident ++ ".tar.gz" tarball <- configPackageTarball (indexName index) ident- return $ Left (indexName index, [(ident, rpCache resolved, ToFetch+ return $ Left (indexName index, [(ident, rpCache resolved, rpGitSHA1 resolved, ToFetch { tfTarball = tarball , tfDestDir = mdestDir , tfUrl = case d of@@ -435,7 +479,7 @@ liftIO $ readTVarIO outputVar where- go :: (MonadIO m,Functor m,MonadThrow m,MonadLogger m,MonadReader env m,HasHttpManager env)+ go :: (MonadIO m,MonadThrow m,MonadLogger m,MonadReader env m,HasHttpManager env) => TVar (Map PackageIdentifier (Path Abs Dir)) -> (m () -> IO ()) -> (PackageIdentifier, ToFetch)
src/Stack/GhcPkg.hs view
@@ -59,7 +59,7 @@ firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n') -- | Run the ghc-pkg executable-ghcPkg :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+ghcPkg :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> [Path Abs Dir]@@ -77,7 +77,7 @@ args' = packageDbFlags pkgDbs ++ args -- | Create a package database in the given directory, if it doesn't exist.-createDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+createDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> Path Abs Dir -> m () createDatabase menv wc db = do exists <- doesDirExist db@@ -102,7 +102,7 @@ -- | Get the value of a field of the package. findGhcPkgField- :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ package databases@@ -125,7 +125,7 @@ stripCR t = fromMaybe t (T.stripSuffix "\r" t) -- | Get the version of the package-findGhcPkgVersion :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+findGhcPkgVersion :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ package databases@@ -137,7 +137,7 @@ Just !v -> return (parseVersion v) _ -> return Nothing -unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m)+unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) => EnvOverride -> WhichCompiler -> CompilerVersion
src/Stack/Ghci.hs view
@@ -18,17 +18,19 @@ import Control.Applicative import Control.Exception.Enclosed (tryAny)+import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.RWS.Strict import Control.Monad.State.Strict-import Control.Monad.Trans.Resource+import Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.ByteString.Char8 as S8 import Data.Either import Data.Function import Data.List import Data.List.Extra (nubOrd)+import Data.List.Split (splitOn) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe@@ -54,6 +56,7 @@ import Stack.Package import Stack.Types import Stack.Types.Internal+import System.FilePath (takeBaseName) import Text.Read (readMaybe) #ifndef WINDOWS@@ -105,7 +108,7 @@ -- given options and configure it with the load paths and extensions -- of those targets. ghci- :: (HasConfig r, HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)+ :: (HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadBaseUnlift IO m) => GhciOpts -> m () ghci opts@GhciOpts{..} = do bopts <- asks (configBuild . getConfig)@@ -124,7 +127,7 @@ getUserOptions Nothing ++ concatMap (getUserOptions . Just . ghciPkgName) pkgs getUserOptions mpkg =- map T.unpack (M.findWithDefault [] mpkg (configGhcOptions config))+ map T.unpack (M.findWithDefault [] mpkg (unGhcOptions (configGhcOptions config))) badForGhci x = isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky -static -Werror") unless (null omittedOpts) $@@ -134,8 +137,22 @@ allModules <- checkForDuplicateModules ghciNoLoadModules pkgs oiDir <- objectInterfaceDir bconfig (modulesToLoad, mainFile) <- if ghciNoLoadModules then return ([], Nothing) else do- mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs- return (allModules, mainFile)+ mmainFile <- figureOutMainFile bopts mainIsTargets targets pkgs+ modulesToLoad <- case mmainFile of+ Just mainFile -> do+ let (_, mfDirs, mfName) = filePathPieces mainFile+ mainPathPieces = map toFilePath mfDirs ++ [takeBaseName (toFilePath mfName)]+ liftM catMaybes $ forM allModules $ \mn -> do+ let matchesModule = splitOn "." mn `isSuffixOf` mainPathPieces+ if matchesModule+ then do+ $logWarn $ "Warning: Omitting load of module " <> T.pack mn <>+ ", because it matches the filepath of the Main target, " <>+ T.pack (toFilePath mainFile)+ return Nothing+ else return (Just mn)+ Nothing -> return allModules+ return (modulesToLoad, mmainFile) let odir = [ "-odir=" <> toFilePathNoTrailingSep oiDir , "-hidir=" <> toFilePathNoTrailingSep oiDir ]@@ -159,7 +176,7 @@ else do let scriptPath = tmpDir </> $(mkRelFile "ghci-script") fp = toFilePath scriptPath- loadModules = ":load " <> unwords (map show modulesToLoad)+ loadModules = ":add " <> unwords (map show modulesToLoad) addMainFile = maybe "" ((":add " <>) . toFilePath) mainFile bringIntoScope = ":module + " <> unwords modulesToLoad liftIO (writeFile fp (unlines [loadModules,addMainFile,bringIntoScope]))@@ -170,7 +187,7 @@ -- is none, sometimes it's unambiguous, sometimes it's -- ambiguous. Warns and returns nothing if it's ambiguous. figureOutMainFile- :: (Monad m, MonadLogger m, MonadIO m)+ :: (MonadLogger m, MonadIO m) => BuildOpts -> Maybe (Map PackageName SimpleTarget) -> Map PackageName SimpleTarget@@ -256,11 +273,11 @@ -- | Create a list of infos for each target containing necessary -- information to load that package/components. ghciSetup- :: (HasConfig r, HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)+ :: (HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadBaseUnlift IO m) => GhciOpts -> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo]) ghciSetup GhciOpts{..} = do- (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets ghciBuildOptsCLI + (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets ghciBuildOptsCLI mainIsTargets <- case ghciMainIs of Nothing -> return Nothing@@ -357,7 +374,8 @@ PackageConfig { packageConfigEnableTests = True , packageConfigEnableBenchmarks = True- , packageConfigFlags = localFlags (boptsCLIFlags boptsCli) bconfig name+ , packageConfigFlags = getLocalFlags bconfig boptsCli name+ , packageConfigGhcOptions = getGhcOptions bconfig boptsCli name True True , packageConfigCompilerVersion = envConfigCompilerVersion econfig , packageConfigPlatform = configPlatform (getConfig bconfig) }@@ -543,3 +561,10 @@ , Posix.otherReadMode ] #endif++filePathPieces :: Path Abs File -> (Path Abs Dir, [Path Rel Dir], Path Rel File)+filePathPieces x0 = go (parent x0, [], filename x0)+ where+ go (x, dirs, fp)+ | parent x == x = (x, dirs, fp)+ | otherwise = (parent x, dirname x : dirs, fp)
src/Stack/Ide.hs view
@@ -15,7 +15,7 @@ import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Trans.Unlift (MonadBaseUnlift) import Data.List import Data.Maybe import Data.Monoid@@ -39,7 +39,7 @@ -- given options and configure it with the load paths and extensions -- of those targets. ide- :: (HasConfig r, HasBuildConfig r, HasTerminal r, HasLogLevel r, MonadMask m, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, HasHttpManager r)+ :: (HasConfig r, HasBuildConfig r, HasTerminal r, HasLogLevel r, MonadMask m, HasEnvConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadBaseUnlift IO m, HasHttpManager r) => [Text] -- ^ Targets. -> [String] -- ^ GHC options. -> m ()
src/Stack/Init.hs view
@@ -55,11 +55,12 @@ , MonadReader env m, HasConfig env , HasGHCVariant env , HasHttpManager env , HasLogLevel env , HasReExec env , HasTerminal env)- => Path Abs Dir+ => WhichSolverCmd+ -> Path Abs Dir -> InitOpts -> Maybe AbstractResolver -> m ()-initProject currDir initOpts mresolver = do+initProject whichCmd currDir initOpts mresolver = do let dest = currDir </> stackDotYaml reldest <- toFilePath `liftM` makeRelativeToCurrentDir dest@@ -79,7 +80,7 @@ cabalfps <- liftM concat $ mapM find dirs' (bundle, dupPkgs) <- cabalPackagesCheck cabalfps noPkgMsg Nothing - (r, flags, extraDeps, rbundle) <- getDefaultResolver dest initOpts+ (r, flags, extraDeps, rbundle) <- getDefaultResolver whichCmd dest initOpts mresolver bundle let ignored = Map.difference bundle rbundle@@ -118,7 +119,7 @@ { projectUserMsg = if userMsg == "" then Nothing else Just userMsg , projectPackages = pkgs , projectExtraDeps = extraDeps- , projectFlags = removeSrcPkgDefaultFlags gpds flags+ , projectFlags = PackageFlags (removeSrcPkgDefaultFlags gpds flags) , projectResolver = r , projectCompiler = Nothing , projectExtraPackageDBs = []@@ -331,7 +332,8 @@ , MonadReader env m, HasConfig env , HasGHCVariant env , HasHttpManager env , HasLogLevel env , HasReExec env , HasTerminal env)- => Path Abs File -- ^ stack.yaml+ => WhichSolverCmd+ -> Path Abs File -- ^ stack.yaml -> InitOpts -> Maybe AbstractResolver -> Map PackageName (Path Abs File, C.GenericPackageDescription)@@ -344,9 +346,9 @@ -- , Flags for src packages and extra deps -- , Extra dependencies -- , Src packages actually considered)-getDefaultResolver stackYaml initOpts mresolver bundle =+getDefaultResolver whichCmd stackYaml initOpts mresolver bundle = maybe selectSnapResolver makeConcreteResolver mresolver- >>= getWorkingResolverPlan stackYaml initOpts bundle+ >>= getWorkingResolverPlan whichCmd stackYaml initOpts bundle where -- TODO support selecting best across regular and custom snapshots selectSnapResolver = do@@ -355,7 +357,7 @@ (s, r) <- selectBestSnapshot gpds snaps case r of BuildPlanCheckFail {} | not (omitPackages initOpts)- -> throwM (NoMatchingSnapshot snaps)+ -> throwM (NoMatchingSnapshot whichCmd snaps) _ -> return $ ResolverSnapshot s getWorkingResolverPlan@@ -363,7 +365,8 @@ , MonadReader env m, HasConfig env , HasGHCVariant env , HasHttpManager env , HasLogLevel env , HasReExec env , HasTerminal env)- => Path Abs File -- ^ stack.yaml+ => WhichSolverCmd+ -> Path Abs File -- ^ stack.yaml -> InitOpts -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description@@ -376,12 +379,12 @@ -- , Flags for src packages and extra deps -- , Extra dependencies -- , Src packages actually considered)-getWorkingResolverPlan stackYaml initOpts bundle resolver = do+getWorkingResolverPlan whichCmd stackYaml initOpts bundle resolver = do $logInfo $ "Selected resolver: " <> resolverName resolver go bundle where go info = do- eres <- checkBundleResolver stackYaml initOpts info resolver+ eres <- checkBundleResolver whichCmd stackYaml initOpts info resolver -- if some packages failed try again using the rest case eres of Right (f, edeps)-> return (resolver, f, edeps, info)@@ -413,14 +416,15 @@ , MonadReader env m, HasConfig env , HasGHCVariant env , HasHttpManager env , HasLogLevel env , HasReExec env , HasTerminal env)- => Path Abs File -- ^ stack.yaml+ => WhichSolverCmd+ -> Path Abs File -- ^ stack.yaml -> InitOpts -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description -> Resolver -> m (Either [PackageName] ( Map PackageName (Map FlagName Bool) , Map PackageName Version))-checkBundleResolver stackYaml initOpts bundle resolver = do+checkBundleResolver whichCmd stackYaml initOpts bundle resolver = do result <- checkResolverSpec gpds Nothing resolver case result of BuildPlanCheckOk f -> return $ Right (f, Map.empty)@@ -432,14 +436,14 @@ warnPartial result $logWarn "*** Omitting packages with unsatisfied dependencies" return $ Left $ failedUserPkgs e- | otherwise -> throwM $ ResolverPartial resolver (show result)+ | otherwise -> throwM $ ResolverPartial whichCmd resolver (show result) BuildPlanCheckFail _ e _ | omitPackages initOpts -> do $logWarn $ "*** Resolver compiler mismatch: " <> resolverName resolver $logWarn $ indent $ T.pack $ show result return $ Left $ failedUserPkgs e- | otherwise -> throwM $ ResolverMismatch resolver (show result)+ | otherwise -> throwM $ ResolverMismatch whichCmd resolver (show result) where indent t = T.unlines $ fmap (" " <>) (T.lines t) warnPartial res = do
src/Stack/New.hs view
@@ -17,7 +17,6 @@ , listTemplates) where -import Control.Applicative import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class@@ -80,7 +79,7 @@ -- | Create a new project with the given options. new- :: (HasConfig r, MonadReader r m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m, HasHttpManager r, Functor m, Applicative m)+ :: (HasConfig r, MonadReader r m, MonadLogger m, MonadCatch m, MonadIO m, HasHttpManager r) => NewOpts -> Bool -> m (Path Abs Dir) new opts forceOverwrite = do pwd <- getCurrentDir@@ -88,7 +87,7 @@ else do relDir <- parseRelDir (packageNameString project) liftM (pwd </>) (return relDir) exists <- doesDirExist absDir- configTemplate <- configDefaultTemplate <$> asks getConfig+ configTemplate <- asks (configDefaultTemplate . getConfig) let template = fromMaybe defaultTemplateName $ asum [ cliOptionTemplate , configTemplate ]@@ -130,10 +129,10 @@ -- | Download and read in a template's text content. loadTemplate :: forall m r.- (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m, Functor m, Applicative m)+ (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => TemplateName -> (TemplateFrom -> m ()) -> m Text loadTemplate name logIt = do- templateDir <- templatesDir <$> asks getConfig+ templateDir <- asks (templatesDir . getConfig) case templatePath name of AbsPath absFile -> logIt LocalTemp >> loadLocalFile absFile UrlPath s -> do@@ -144,7 +143,9 @@ downloadTemplate req (templateDir </> rel) RelPath relFile -> catch- (loadLocalFile relFile <* logIt LocalTemp)+ (do f <- loadLocalFile relFile+ logIt LocalTemp+ return f) (\(e :: NewException) -> case relRequest relFile of Just req -> downloadTemplate req@@ -174,7 +175,7 @@ -- | Apply and unpack a template into a directory. applyTemplate- :: (MonadIO m, MonadThrow m, MonadCatch m, MonadReader r m, HasConfig r, MonadLogger m)+ :: (MonadIO m, MonadCatch m, MonadReader r m, HasConfig r, MonadLogger m) => PackageName -> TemplateName -> Map Text Text@@ -270,7 +271,7 @@ -- | Display the set of templates accompanied with description if available. listTemplates- :: (MonadIO m, MonadThrow m, MonadReader r m, HasHttpManager r, MonadCatch m, MonadLogger m)+ :: (MonadIO m, MonadReader r m, HasHttpManager r, MonadCatch m) => m () listTemplates = do templates <- getTemplates@@ -289,7 +290,7 @@ -- | Get the set of templates. getTemplates- :: (MonadIO m, MonadThrow m, MonadReader r m, HasHttpManager r, MonadCatch m)+ :: (MonadIO m, MonadReader r m, HasHttpManager r, MonadCatch m) => m (Set TemplateName) getTemplates = do req <- liftM addHeaders (parseUrl defaultTemplatesList)@@ -303,7 +304,7 @@ code -> throwM (BadTemplatesResponse code) getTemplateInfo- :: (MonadIO m, MonadThrow m, MonadReader r m, HasHttpManager r, MonadCatch m, MonadLogger m)+ :: (MonadIO m, MonadReader r m, HasHttpManager r, MonadCatch m) => m (Map Text TemplateInfo) getTemplateInfo = do req <- liftM addHeaders (parseUrl defaultTemplateInfoUrl)
src/Stack/Options.hs view
@@ -22,6 +22,7 @@ ,ghciOptsParser ,solverOptsParser ,testOptsParser+ ,haddockOptsParser ,hpcReportOptsParser ,pvpBoundsOption ,globalOptsFromMonoid@@ -36,7 +37,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe-import Data.Monoid+import Data.Monoid.Extra import qualified Data.Set as Set import qualified Data.Text as T import Data.Text.Read (decimal)@@ -77,12 +78,12 @@ -- FIXME hiding options benchOptsParser :: Bool -> Parser BenchmarkOptsMonoid benchOptsParser hide0 = BenchmarkOptsMonoid- <$> optional (strOption (long "benchmark-arguments" <>+ <$> optionalFirst (strOption (long "benchmark-arguments" <> metavar "BENCH_ARGS" <> help ("Forward BENCH_ARGS to the benchmark suite. " <> "Supports templates from `cabal bench`") <> hide))- <*> optional (switch (long "no-run-benchmarks" <>+ <*> optionalFirst (switch (long "no-run-benchmarks" <> help "Disable running of benchmarks. (Benchmarks will still be built.)" <> hide)) where hide = hideMods hide0@@ -222,14 +223,14 @@ , configMonoidModifyCodePage = modifyCodePage , configMonoidAllowDifferentUser = allowDifferentUser })- <$> optional (option readAbsDir+ <$> optionalFirst (option readAbsDir ( long stackRootOptionName <> metavar (map toUpper stackRootOptionName) <> help ("Absolute path to the global stack root directory " ++ "(Overrides any STACK_ROOT environment variable)") <> hide ))- <*> optional (strOption+ <*> optionalFirst (strOption ( long "work-dir" <> metavar "WORK-DIR" <> help "Override work directory (default: .stack-work)"@@ -238,28 +239,28 @@ <*> buildOptsMonoidParser (hide0 /= BuildCmdGlobalOpts) <*> dockerOptsParser True <*> nixOptsParser True- <*> maybeBoolFlags+ <*> firstBoolFlags "system-ghc" "using the system installed GHC (on the PATH) if available and a matching version" hide- <*> maybeBoolFlags+ <*> firstBoolFlags "install-ghc" "downloading and installing GHC if necessary (can be done manually with stack setup)" hide- <*> optional (strOption+ <*> optionalFirst (strOption ( long "arch" <> metavar "ARCH" <> help "System architecture, e.g. i386, x86_64" <> hide ))- <*> optional (strOption+ <*> optionalFirst (strOption ( long "os" <> metavar "OS" <> help "Operating system, e.g. linux, windows" <> hide ))- <*> optional (ghcVariantParser (hide0 /= OuterGlobalOpts))- <*> optional (option auto+ <*> optionalFirst (ghcVariantParser (hide0 /= OuterGlobalOpts))+ <*> optionalFirst (option auto ( long "jobs" <> short 'j' <> metavar "JOBS"@@ -278,25 +279,25 @@ <> help "Extra directories to check for libraries" <> hide )))- <*> maybeBoolFlags+ <*> firstBoolFlags "skip-ghc-check" "skipping the GHC version and architecture check" hide- <*> maybeBoolFlags+ <*> firstBoolFlags "skip-msys" "skipping the local MSYS installation (Windows only)" hide- <*> optional (strOption+ <*> optionalFirst (strOption ( long "local-bin-path" <> metavar "DIR" <> help "Install binaries to DIR" <> hide ))- <*> maybeBoolFlags+ <*> firstBoolFlags "modify-code-page" "setting the codepage to support UTF-8 (Windows only)" hide- <*> maybeBoolFlags+ <*> firstBoolFlags "allow-different-user" ("permission for users other than the owner of the stack root " ++ "directory to use a stack installation (POSIX only)")@@ -324,11 +325,11 @@ enable opts | tracing || profiling = opts- { buildMonoidLibProfile = Just True- , buildMonoidExeProfile = Just True+ { buildMonoidLibProfile = First (Just True)+ , buildMonoidExeProfile = First (Just True) , buildMonoidBenchmarkOpts = bopts- { beoMonoidAdditionalArgs = beoMonoidAdditionalArgs bopts <>- Just (" " <> unwords additionalArgs)+ { beoMonoidAdditionalArgs = First (getFirst (beoMonoidAdditionalArgs bopts) <>+ Just (" " <> unwords additionalArgs)) } , buildMonoidTestOpts = topts { toMonoidAdditionalArgs = (toMonoidAdditionalArgs topts) <>@@ -374,74 +375,75 @@ \exception" <> hide) options =- BuildOptsMonoid <$> libProfiling <*> exeProfiling <*> haddock <*> openHaddocks <*>+ BuildOptsMonoid <$> libProfiling <*> exeProfiling <*> haddock <*>+ haddockOptsParser hide0 <*> openHaddocks <*> haddockDeps <*> copyBins <*> preFetch <*> keepGoing <*> forceDirty <*> tests <*> testOptsParser hide0 <*> benches <*> benchOptsParser hide0 <*> reconfigure <*> cabalVerbose <*> splitObjs libProfiling =- maybeBoolFlags+ firstBoolFlags "library-profiling" "library profiling for TARGETs and all its dependencies" hide exeProfiling =- maybeBoolFlags+ firstBoolFlags "executable-profiling" "executable profiling for TARGETs and all its dependencies" hide haddock =- maybeBoolFlags+ firstBoolFlags "haddock" "generating Haddocks the package(s) in this directory/configuration" hide openHaddocks =- maybeBoolFlags+ firstBoolFlags "open" "opening the local Haddock documentation in the browser" hide haddockDeps =- maybeBoolFlags "haddock-deps" "building Haddocks for dependencies" hide+ firstBoolFlags "haddock-deps" "building Haddocks for dependencies" hide copyBins =- maybeBoolFlags+ firstBoolFlags "copy-bins" "copying binaries to the local-bin-path (see 'stack path')" hide keepGoing =- maybeBoolFlags+ firstBoolFlags "keep-going" "continue running after a step fails (default: false for build, true for test/bench)" hide preFetch =- maybeBoolFlags+ firstBoolFlags "prefetch" "Fetch packages necessary for the build immediately, useful with --dry-run" hide forceDirty =- maybeBoolFlags+ firstBoolFlags "force-dirty" "Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change" hide tests =- maybeBoolFlags+ firstBoolFlags "test" "testing the package(s) in this directory/configuration" hide benches =- maybeBoolFlags+ firstBoolFlags "bench" "benchmarking the package(s) in this directory/configuration" hide reconfigure =- maybeBoolFlags+ firstBoolFlags "reconfigure" "Perform the configure step even if unnecessary. Useful in some corner cases with custom Setup.hs files" hide cabalVerbose =- maybeBoolFlags+ firstBoolFlags "cabal-verbose" "Ask Cabal to be verbose in its output" hide splitObjs =- maybeBoolFlags+ firstBoolFlags "split-objs" ("Enable split-objs, to reduce output size (at the cost of build time). " ++ splitObjsWarning) hide@@ -449,77 +451,85 @@ nixOptsParser :: Bool -> Parser NixOptsMonoid nixOptsParser hide0 = overrideActivation <$> (NixOptsMonoid- <$> pure False- <*> maybeBoolFlags nixCmdName+ <$> pure (Any False)+ <*> firstBoolFlags nixCmdName "use of a Nix-shell" hide- <*> maybeBoolFlags "nix-pure"+ <*> firstBoolFlags "nix-pure" "use of a pure Nix-shell" hide- <*> (fmap (map T.pack)- <$> optional (argsOption (long "nix-packages" <>- metavar "NAMES" <>- help "List of packages that should be available in the nix-shell (space separated)" <>- hide)))- <*> optional (option str (long "nix-shell-file" <>- metavar "FILEPATH" <>- help "Nix file to be used to launch a nix-shell (for regular Nix users)" <>- hide))- <*> (fmap (map T.pack)- <$> optional (argsOption (long "nix-shell-options" <>- metavar "OPTIONS" <>- help "Additional options passed to nix-shell" <>- hide)))- <*> (fmap (map T.pack)- <$> optional (argsOption (long "nix-path" <>- metavar "PATH_OPTIONS" <>- help "Additional options to override NIX_PATH parts (notably 'nixpkgs')" <>- hide)))+ <*> optionalFirst+ (textArgsOption+ (long "nix-packages" <>+ metavar "NAMES" <>+ help "List of packages that should be available in the nix-shell (space separated)" <>+ hide))+ <*> optionalFirst+ (option+ str+ (long "nix-shell-file" <>+ metavar "FILEPATH" <>+ help "Nix file to be used to launch a nix-shell (for regular Nix users)" <>+ hide))+ <*> optionalFirst+ (textArgsOption+ (long "nix-shell-options" <>+ metavar "OPTIONS" <>+ help "Additional options passed to nix-shell" <>+ hide))+ <*> optionalFirst+ (textArgsOption+ (long "nix-path" <>+ metavar "PATH_OPTIONS" <>+ help "Additional options to override NIX_PATH parts (notably 'nixpkgs')" <>+ hide)) ) where hide = hideMods hide0 overrideActivation m =- if m /= mempty then m { nixMonoidEnable = Just . fromMaybe True $ nixMonoidEnable m }+ if m /= mempty then m { nixMonoidEnable = (First . Just . fromFirst True) (nixMonoidEnable m) } else m+ textArgsOption = fmap (map T.pack) . argsOption -- | Options parser configuration for Docker. dockerOptsParser :: Bool -> Parser DockerOptsMonoid dockerOptsParser hide0 = DockerOptsMonoid- <$> pure False- <*> maybeBoolFlags dockerCmdName+ <$> pure (Any False)+ <*> firstBoolFlags dockerCmdName "using a Docker container" hide- <*> ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <>- hide <>- metavar "NAME" <>- help "Docker repository name") <|>- (Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <>- hide <>- metavar "IMAGE" <>- help "Exact Docker image ID (overrides docker-repo)") <|>+ <*> fmap First+ ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <>+ hide <>+ metavar "NAME" <>+ help "Docker repository name") <|>+ (Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <>+ hide <>+ metavar "IMAGE" <>+ help "Exact Docker image ID (overrides docker-repo)") <|> pure Nothing)- <*> maybeBoolFlags (dockerOptName dockerRegistryLoginArgName)+ <*> firstBoolFlags (dockerOptName dockerRegistryLoginArgName) "registry requires login" hide- <*> maybeStrOption (long (dockerOptName dockerRegistryUsernameArgName) <>+ <*> firstStrOption (long (dockerOptName dockerRegistryUsernameArgName) <> hide <> metavar "USERNAME" <> help "Docker registry username")- <*> maybeStrOption (long (dockerOptName dockerRegistryPasswordArgName) <>+ <*> firstStrOption (long (dockerOptName dockerRegistryPasswordArgName) <> hide <> metavar "PASSWORD" <> help "Docker registry password")- <*> maybeBoolFlags (dockerOptName dockerAutoPullArgName)+ <*> firstBoolFlags (dockerOptName dockerAutoPullArgName) "automatic pulling latest version of image" hide- <*> maybeBoolFlags (dockerOptName dockerDetachArgName)+ <*> firstBoolFlags (dockerOptName dockerDetachArgName) "running a detached Docker container" hide- <*> maybeBoolFlags (dockerOptName dockerPersistArgName)+ <*> firstBoolFlags (dockerOptName dockerPersistArgName) "not deleting container after it exits" hide- <*> maybeStrOption (long (dockerOptName dockerContainerNameArgName) <>+ <*> firstStrOption (long (dockerOptName dockerContainerNameArgName) <> hide <> metavar "NAME" <> help "Docker container name")@@ -538,11 +548,11 @@ metavar "NAME=VALUE" <> help ("Set environment variable in container " ++ "(may specify multiple times)")))- <*> maybeStrOption (long (dockerOptName dockerDatabasePathArgName) <>+ <*> firstStrOption (long (dockerOptName dockerDatabasePathArgName) <> hide <> metavar "PATH" <> help "Location of image usage tracking database")- <*> maybeStrOption+ <*> firstStrOption (long(dockerOptName dockerStackExeArgName) <> hide <> metavar (intercalate "|"@@ -553,13 +563,13 @@ help (concat [ "Location of " , stackProgName , " executable used in container" ]))- <*> maybeBoolFlags (dockerOptName dockerSetUserArgName)+ <*> firstBoolFlags (dockerOptName dockerSetUserArgName) "setting user in container to match host" hide- <*> pure anyVersion+ <*> pure (IntersectingVersionRange anyVersion) where dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName- maybeStrOption = optional . option str+ firstStrOption = optionalFirst . option str hide = hideMods hide0 -- | Parser for docker cleanup arguments.@@ -715,21 +725,23 @@ globalOptsParser :: GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid globalOptsParser kind defLogLevel = GlobalOptsMonoid <$>- optional (strOption (long Docker.reExecArgName <> hidden <> internal)) <*>- optional (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*>- logLevelOptsParser hide0 defLogLevel <*>+ optionalFirst (strOption (long Docker.reExecArgName <> hidden <> internal)) <*>+ optionalFirst (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*>+ (First <$> logLevelOptsParser hide0 defLogLevel) <*> configOptsParser kind <*>- optional (abstractResolverOptsParser hide0) <*>- optional (compilerOptsParser hide0) <*>- maybeBoolFlags+ optionalFirst (abstractResolverOptsParser hide0) <*>+ optionalFirst (compilerOptsParser hide0) <*>+ firstBoolFlags "terminal" "overriding terminal detection in the case of running in a false terminal" hide <*>- optional (strOption (long "stack-yaml" <>- metavar "STACK-YAML" <>- help ("Override project stack.yaml file " <>- "(overrides any STACK_YAML environment variable)") <>- hide))+ optionalFirst+ (strOption+ (long "stack-yaml" <>+ metavar "STACK-YAML" <>+ help ("Override project stack.yaml file " <>+ "(overrides any STACK_YAML environment variable)") <>+ hide)) where hide = hideMods hide0 hide0 = kind /= OuterGlobalOpts@@ -737,14 +749,14 @@ -- | Create GlobalOpts from GlobalOptsMonoid. globalOptsFromMonoid :: Bool -> GlobalOptsMonoid -> GlobalOpts globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts- { globalReExecVersion = globalMonoidReExecVersion- , globalDockerEntrypoint = globalMonoidDockerEntrypoint- , globalLogLevel = fromMaybe defaultLogLevel globalMonoidLogLevel+ { globalReExecVersion = getFirst globalMonoidReExecVersion+ , globalDockerEntrypoint = getFirst globalMonoidDockerEntrypoint+ , globalLogLevel = fromFirst defaultLogLevel globalMonoidLogLevel , globalConfigMonoid = globalMonoidConfigMonoid- , globalResolver = globalMonoidResolver- , globalCompiler = globalMonoidCompiler- , globalTerminal = fromMaybe defaultTerminal globalMonoidTerminal- , globalStackYaml = globalMonoidStackYaml }+ , globalResolver = getFirst globalMonoidResolver+ , globalCompiler = getFirst globalMonoidCompiler+ , globalTerminal = fromFirst defaultTerminal globalMonoidTerminal+ , globalStackYaml = getFirst globalMonoidStackYaml } initOptsParser :: Parser InitOpts initOptsParser =@@ -861,25 +873,45 @@ "Automatically update stack.yaml with the solver's recommendations" idm +-- | Parser for haddock arguments.+haddockOptsParser :: Bool -> Parser HaddockOptsMonoid+haddockOptsParser hide0 =+ HaddockOptsMonoid <$> fmap (fromMaybe [])+ (optional+ (argsOption+ (long "haddock-arguments" <>+ metavar "HADDOCK_ARGS" <>+ help "Arguments passed to the haddock program" <>+ hide)))+ where hide = hideMods hide0+ -- | Parser for test arguments. -- FIXME hide args testOptsParser :: Bool -> Parser TestOptsMonoid-testOptsParser hide0 = TestOptsMonoid- <$> maybeBoolFlags- "rerun-tests"- "running already successful tests"- hide- <*> fmap (fromMaybe [])- (optional (argsOption(long "test-arguments" <>- metavar "TEST_ARGS" <>- help "Arguments passed in to the test suite program"- <> hide)))- <*> optional (switch (long "coverage" <>- help "Generate a code coverage report"- <> hide))- <*> optional (switch (long "no-run-tests" <>- help "Disable running of tests. (Tests will still be built.)"- <> hide))+testOptsParser hide0 =+ TestOptsMonoid+ <$> firstBoolFlags+ "rerun-tests"+ "running already successful tests"+ hide+ <*> fmap+ (fromMaybe [])+ (optional+ (argsOption+ (long "test-arguments" <>+ metavar "TEST_ARGS" <>+ help "Arguments passed in to the test suite program" <>+ hide)))+ <*> optionalFirst+ (switch+ (long "coverage" <>+ help "Generate a code coverage report" <>+ hide))+ <*> optionalFirst+ (switch+ (long "no-run-tests" <>+ help "Disable running of tests. (Tests will still be built.)" <>+ hide)) where hide = hideMods hide0 -- | Parser for @stack new@.
src/Stack/Package.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -9,7 +10,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-} -- | Dealing with Cabal. @@ -37,21 +38,19 @@ ,cabalFilePackageId) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative, (<$>), (<*>))-#endif+import Prelude ()+import Prelude.Compat import Control.Arrow ((&&&)) import Control.Exception hiding (try,catch)-import Control.Monad+import Control.Monad (liftM, liftM2, (<=<), when, forM, forM_) import Control.Monad.Catch import Control.Monad.IO.Class-import Control.Monad.Logger (MonadLogger,logWarn)-import Control.Monad.Reader+import Control.Monad.Logger+import Control.Monad.Reader (MonadReader,runReaderT,ask,asks) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8-import Data.Function-import Data.List+import Data.List.Compat import Data.List.Extra (nubOrd) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M@@ -85,7 +84,6 @@ import Path.Extra import Path.Find import Path.IO hiding (findFiles)-import Prelude import Safe (headDef, tailSafe) import Stack.Build.Installed import Stack.Constants@@ -120,7 +118,7 @@ dropBOM t = fromMaybe t $ T.stripPrefix "\xFEFF" t -- | Reads and exposes the package information-readPackage :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)+readPackage :: (MonadLogger m, MonadIO m, MonadCatch m) => PackageConfig -> Path Abs File -> m ([PWarning],Package)@@ -139,7 +137,7 @@ -- | Get 'GenericPackageDescription' and 'PackageDescription' reading info -- from given directory.-readPackageDescriptionDir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)+readPackageDescriptionDir :: (MonadLogger m, MonadIO m, MonadCatch m) => PackageConfig -> Path Abs Dir -> m (GenericPackageDescription, PackageDescription)@@ -187,6 +185,7 @@ , packageDeps = deps , packageFiles = pkgFiles , packageTools = packageDescTools pkg+ , packageGhcOptions = packageConfigGhcOptions packageConfig , packageFlags = packageConfigFlags packageConfig , packageDefaultFlags = M.fromList [(fromCabalFlagName (flagName flag), flagDefault flag) | flag <- genPackageFlags gpkg]@@ -196,11 +195,11 @@ [(T.pack (testName t), testInterface t) | t <- testSuites pkg , buildable (testBuildInfo t)] , packageBenchmarks = S.fromList- [T.pack (benchmarkName b) | b <- benchmarks pkg- , buildable (benchmarkBuildInfo b)]+ [T.pack (benchmarkName biBuildInfo) | biBuildInfo <- benchmarks pkg+ , buildable (benchmarkBuildInfo biBuildInfo)] , packageExes = S.fromList- [T.pack (exeName b) | b <- executables pkg- , buildable (buildInfo b)]+ [T.pack (exeName biBuildInfo) | biBuildInfo <- executables pkg+ , buildable (buildInfo biBuildInfo)] , packageOpts = GetPackageOpts $ \sourceMap installedMap omitPkgs addPkgs cabalfp -> do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp@@ -246,7 +245,7 @@ -- options which apply generally to the package, not one specific -- component. generatePkgDescOpts- :: (HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadIO m)+ :: (HasEnvConfig env, MonadThrow m, MonadReader env m, MonadIO m) => SourceMap -> InstalledMap -> [PackageName] -- ^ Packages to omit from the "-package" / "-package-id" flags@@ -256,6 +255,7 @@ -> Map NamedComponent (Set DotCabalPath) -> m (Map NamedComponent BuildInfoOpts) generatePkgDescOpts sourceMap installedMap omitPkgs addPkgs cabalfp pkg componentPaths = do+ config <- asks getConfig distDir <- distDirFromDir cabalDir let cabalMacros = autogenDir distDir </> $(mkRelFile "cabal_macros.h") exists <- doesFileExist cabalMacros@@ -265,17 +265,21 @@ else Nothing let generate namedComponent binfo = ( namedComponent- , generateBuildInfoOpts- sourceMap- installedMap- mcabalMacros- cabalDir- distDir- omitPkgs- addPkgs- binfo- (fromMaybe mempty (M.lookup namedComponent componentPaths))- namedComponent)+ , generateBuildInfoOpts BioInput+ { biSourceMap = sourceMap+ , biInstalledMap = installedMap+ , biCabalMacros = mcabalMacros+ , biCabalDir = cabalDir+ , biDistDir = distDir+ , biOmitPackages = omitPkgs+ , biAddPackages = addPkgs+ , biBuildInfo = binfo+ , biDotCabalPaths = fromMaybe mempty (M.lookup namedComponent componentPaths)+ , biConfigLibDirs = configExtraLibDirs config+ , biConfigIncludeDirs = configExtraIncludeDirs config+ , biComponentName = namedComponent+ }+ ) return ( M.fromList (concat@@ -304,22 +308,26 @@ where cabalDir = parent cabalfp +data BioInput = BioInput+ { biSourceMap :: !SourceMap+ , biInstalledMap :: !InstalledMap+ , biCabalMacros :: !(Maybe (Path Abs File))+ , biCabalDir :: !(Path Abs Dir)+ , biDistDir :: !(Path Abs Dir)+ , biOmitPackages :: ![PackageName]+ , biAddPackages :: ![PackageName]+ , biBuildInfo :: !BuildInfo+ , biDotCabalPaths :: !(Set DotCabalPath)+ , biConfigLibDirs :: !(Set Text)+ , biConfigIncludeDirs :: !(Set Text)+ , biComponentName :: !NamedComponent+ }+ -- | Generate GHC options for the target.-generateBuildInfoOpts- :: SourceMap- -> InstalledMap- -> Maybe (Path Abs File)- -> Path Abs Dir- -> Path Abs Dir- -> [PackageName]- -> [PackageName]- -> BuildInfo- -> Set DotCabalPath- -> NamedComponent- -> BuildInfoOpts-generateBuildInfoOpts sourceMap installedMap mcabalMacros cabalDir distDir omitPkgs addPkgs b dotCabalPaths componentName =+generateBuildInfoOpts :: BioInput -> BuildInfoOpts+generateBuildInfoOpts BioInput {..} = BuildInfoOpts- { bioOpts = ghcOpts b ++ cppOptions b+ { bioOpts = ghcOpts ++ cppOptions biBuildInfo -- NOTE for future changes: Due to this use of nubOrd (and other uses -- downstream), these generated options must not rely on multiple -- argument sequences. For example, ["--main-is", "Foo.hs", "--main-@@ -328,70 +336,72 @@ -- -- See https://github.com/commercialhaskell/stack/issues/1255 , bioOneWordOpts = nubOrd $ concat- [extOpts b, srcOpts, includeOpts, extra b, extraDirs, fworks b, cObjectFiles]+ [extOpts, srcOpts, includeOpts, libOpts, fworks, cObjectFiles] , bioPackageFlags = deps- , bioCabalMacros = mcabalMacros+ , bioCabalMacros = biCabalMacros } where cObjectFiles = mapMaybe (fmap toFilePath .- makeObjectFilePathFromC cabalDir componentName distDir)+ makeObjectFilePathFromC biCabalDir biComponentName biDistDir) cfiles- cfiles = mapMaybe dotCabalCFilePath (S.toList dotCabalPaths)+ cfiles = mapMaybe dotCabalCFilePath (S.toList biDotCabalPaths)+ -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ... deps = concat- [ case M.lookup name installedMap of+ [ case M.lookup name biInstalledMap of Just (_, Stack.Types.Library _ident ipid) -> ["-package-id=" <> ghcPkgIdString ipid] _ -> ["-package=" <> packageNameString name <> maybe "" -- This empty case applies to e.g. base.- ((("-" <>) . versionString) . sourceVersion)- (M.lookup name sourceMap)]+ ((("-" <>) . versionString) . piiVersion)+ (M.lookup name biSourceMap)] | name <- pkgs] pkgs =- addPkgs +++ biAddPackages ++ [ name- | Dependency cname _ <- targetBuildDepends b+ | Dependency cname _ <- targetBuildDepends biBuildInfo , let name = fromCabalPackageName cname- , name `notElem` omitPkgs]- -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ...- sourceVersion (PSUpstream ver _ _) = ver- sourceVersion (PSLocal localPkg) = packageVersion (lpPackage localPkg)- ghcOpts = concatMap snd . filter (isGhc . fst) . options+ , name `notElem` biOmitPackages]+ ghcOpts = concatMap snd . filter (isGhc . fst) $ options biBuildInfo where isGhc GHC = True isGhc _ = False- extOpts = map (("-X" ++) . display) . usedExtensions+ extOpts = map (("-X" ++) . display) (usedExtensions biBuildInfo) srcOpts = map (("-i" <>) . toFilePathNoTrailingSep)- ([cabalDir | null (hsSourceDirs b)] <>- mapMaybe toIncludeDir (hsSourceDirs b) <>- [autogenDir distDir,buildDir distDir] <>- [makeGenDir (buildDir distDir)- | Just makeGenDir <- [fileGenDirFromComponentName componentName]]) ++- ["-stubdir=" ++ toFilePathNoTrailingSep (buildDir distDir)]- toIncludeDir "." = Just cabalDir- toIncludeDir x = fmap (cabalDir </>) (parseRelDir x)+ ([biCabalDir | null (hsSourceDirs biBuildInfo)] <>+ mapMaybe toIncludeDir (hsSourceDirs biBuildInfo) <>+ [autogenDir biDistDir,buildDir biDistDir] <>+ [makeGenDir (buildDir biDistDir)+ | Just makeGenDir <- [fileGenDirFromComponentName biComponentName]]) +++ ["-stubdir=" ++ toFilePathNoTrailingSep (buildDir biDistDir)]+ toIncludeDir "." = Just biCabalDir+ toIncludeDir x = fmap (biCabalDir </>) (parseRelDir x) includeOpts =- [ "-I" <> toFilePathNoTrailingSep absDir- | dir <- includeDirs b- , absDir <- case (parseAbsDir dir, parseRelDir dir) of- (Just ab, _ ) -> [ab]- (_ , Just rel) -> [cabalDir </> rel]- (Nothing, Nothing ) -> []+ map ("-I" <>) (configExtraIncludeDirs <> pkgIncludeOpts)+ configExtraIncludeDirs =+ map T.unpack (S.toList biConfigIncludeDirs)+ pkgIncludeOpts =+ [ toFilePathNoTrailingSep absDir+ | dir <- includeDirs biBuildInfo+ , absDir <- handleDir dir ]- extra- = map ("-l" <>)- . extraLibs- extraDirs =- [ "-L" <> toFilePathNoTrailingSep absDir- | dir <- extraLibDirs b- , absDir <- case (parseAbsDir dir, parseRelDir dir) of- (Just ab, _ ) -> [ab]- (_ , Just rel) -> [cabalDir </> rel]- (Nothing, Nothing ) -> []+ libOpts =+ map ("-l" <>) (extraLibs biBuildInfo) <>+ map ("-L" <>) (configExtraLibDirs <> pkgLibDirs)+ configExtraLibDirs =+ map T.unpack (S.toList biConfigLibDirs)+ pkgLibDirs =+ [ toFilePathNoTrailingSep absDir+ | dir <- extraLibDirs biBuildInfo+ , absDir <- handleDir dir ]- fworks = map (\fwk -> "-framework=" <> fwk) . frameworks+ handleDir dir = case (parseAbsDir dir, parseRelDir dir) of+ (Just ab, _ ) -> [ab]+ (_ , Just rel) -> [biCabalDir </> rel]+ (Nothing, Nothing ) -> []+ fworks = map (\fwk -> "-framework=" <> fwk) (frameworks biBuildInfo) -- | Make the .o path from the .c file path for a component. Example: --@@ -501,7 +511,7 @@ -- | Get all files referenced by the package. packageDescModulesAndFiles- :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m, MonadCatch m)+ :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadCatch m) => PackageDescription -> m (Map NamedComponent (Set ModuleName), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning]) packageDescModulesAndFiles pkg = do@@ -544,7 +554,7 @@ foldTuples = foldl' (<>) (M.empty, M.empty, []) -- | Resolve globbing of files (e.g. data files) to absolute paths.-resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m,MonadCatch m)+resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadReader (Path Abs File, Path Abs Dir) m,MonadCatch m) => [String] -> m (Set (Path Abs File)) resolveGlobFiles = liftM (S.fromList . catMaybes . concat) .@@ -563,7 +573,7 @@ mapM resolveFileOrWarn names matchDirFileGlob' dir glob = catch- (liftIO (matchDirFileGlob_ dir glob))+ (matchDirFileGlob_ dir glob) (\(e :: IOException) -> if isUserError e then do@@ -588,22 +598,28 @@ -- ["test/package-dump/ghc-7.8.txt","test/package-dump/ghc-7.10.txt"] -- @ ---matchDirFileGlob_ :: String -> String -> IO [String]+matchDirFileGlob_ :: (MonadLogger m, MonadIO m) => String -> String -> m [String] matchDirFileGlob_ dir filepath = case parseFileGlob filepath of- Nothing -> die $ "invalid file glob '" ++ filepath- ++ "'. Wildcards '*' are only allowed in place of the file"- ++ " name, not in the directory name or file extension."- ++ " If a wildcard is used it must be with an file extension."+ Nothing -> liftIO $ die $+ "invalid file glob '" ++ filepath+ ++ "'. Wildcards '*' are only allowed in place of the file"+ ++ " name, not in the directory name or file extension."+ ++ " If a wildcard is used it must be with an file extension." Just (NoGlob filepath') -> return [filepath'] Just (FileGlob dir' ext) -> do- files <- D.getDirectoryContents (dir FilePath.</> dir')- case [ dir' FilePath.</> file- | file <- files- , let (name, ext') = splitExtensions file- , not (null name) && isSuffixOf ext ext' ] of- [] -> die $ "filepath wildcard '" ++ filepath- ++ "' does not match any files."- matches -> return matches+ efiles <- liftIO $ try $ D.getDirectoryContents (dir FilePath.</> dir')+ let matches =+ case efiles of+ Left (_ :: IOException) -> []+ Right files ->+ [ dir' FilePath.</> file+ | file <- files+ , let (name, ext') = splitExtensions file+ , not (null name) && isSuffixOf ext ext'+ ]+ when (null matches) $+ $logWarn $ "WARNING: filepath wildcard '" <> T.pack filepath <> "' does not match any files."+ return matches -- | Get all files referenced by the benchmark. benchmarkFiles@@ -839,7 +855,7 @@ -- extensions, plus find any of their module and TemplateHaskell -- dependencies. resolveFilesAndDeps- :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)+ :: (MonadIO m, MonadLogger m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) => Maybe String -- ^ Package component name -> [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names.@@ -906,7 +922,7 @@ -- | Get the dependencies of a Haskell module file. getDependencies- :: (MonadReader (Path Abs File, Path Abs Dir) m, MonadIO m)+ :: (MonadReader (Path Abs File, Path Abs Dir) m, MonadIO m, MonadCatch m, MonadLogger m) => Maybe String -> DotCabalPath -> m (Set ModuleName, [Path Abs File]) getDependencies component dotCabalPath = case dotCabalPath of@@ -935,7 +951,7 @@ -- | Parse a .dump-hi file into a set of modules and files. parseDumpHI- :: (MonadReader (Path Abs File, void) m, MonadIO m)+ :: (MonadReader (Path Abs File, void) m, MonadIO m, MonadCatch m, MonadLogger m) => FilePath -> m (Set ModuleName, [Path Abs File]) parseDumpHI dumpHIPath = do dir <- asks (parent . fst)@@ -953,17 +969,17 @@ -- The dependent file path is surrounded by quotes but is not escaped. -- It can be an absolute or relative path. mapMaybe- (parseAbsOrRelFile dir <=<- (fmap T.unpack .+ ((fmap T.unpack . (T.stripSuffix "\"" <=< T.stripPrefix "\"") . T.dropWhileEnd (== '\r') . decodeUtf8 . C8.dropWhile (/= '"'))) $ filter ("addDependentFile \"" `C8.isPrefixOf`) dumpHI- return (moduleDeps, thDeps)- where- parseAbsOrRelFile dir fp =- case parseRelFile fp of- Just rel -> Just (dir </> rel)- Nothing -> parseAbsFile fp+ thDepsResolved <- liftM catMaybes $ forM thDeps $ \x -> do+ mresolved <- forgivingAbsence (resolveFile dir x) >>= rejectMissingFile+ when (isNothing mresolved) $+ $logWarn $ "Warning: qAddDepedency path listed in " <> T.pack dumpHIPath <>+ " does not exist: " <> T.pack x+ return mresolved+ return (moduleDeps, thDepsResolved) -- | Try to resolve the list of base names in the given directory by -- looking for unique instances of base names applied with the given@@ -1093,32 +1109,12 @@ -- If the directory contains a file named package.yaml, hpack is used to -- generate a .cabal file from it. findOrGenerateCabalFile- :: forall m. (MonadThrow m, MonadIO m)+ :: forall m. (MonadThrow m, MonadIO m, MonadLogger m) => Path Abs Dir -- ^ package directory -> m (Path Abs File) findOrGenerateCabalFile pkgDir = do- mPackageYaml <- Path.IO.findFile [pkgDir] $(mkRelFile "package.yaml")- case mPackageYaml of- Nothing -> findCabalFile- Just packageYaml -> do- eCabalFile <- findCabalFile'- case eCabalFile of- -- Check that cabal file is fresh enough- Right cabalFile -> do- packageYamlModified <- getModificationTime packageYaml- cabalFileModified <- getModificationTime cabalFile- when (cabalFileModified < packageYamlModified) $ liftIO $ hpack pkgDir- -- Important to research again- findCabalFile-- -- If we cannot find cabal file, but have package.yaml- -- run hpack and try to find cabal file again- Left (PackageNoCabalFileFound _) -> do- liftIO $ hpack pkgDir- findCabalFile-- -- Rethrow exception- Left e -> throwM e+ hpack pkgDir+ findCabalFile where findCabalFile :: m (Path Abs File) findCabalFile = findCabalFile' >>= either throwM return@@ -1142,11 +1138,25 @@ where hasExtension fp x = FilePath.takeExtension fp == "." ++ x -- | Generate .cabal file from package.yaml, if necessary.-hpack :: Path Abs Dir -> IO ()+hpack :: (MonadIO m, MonadLogger m) => Path Abs Dir -> m () hpack pkgDir = do- exists <- doesFileExist (pkgDir </> $(mkRelFile Hpack.packageConfig))+ let hpackFile = pkgDir </> $(mkRelFile Hpack.packageConfig)+ exists <- liftIO $ doesFileExist hpackFile when exists $ do- Hpack.hpack (toFilePath pkgDir) True+ let fpt = T.pack (toFilePath hpackFile)+ $logDebug $ "Running hpack on " <> fpt+ r <- liftIO $ Hpack.hpackResult (toFilePath pkgDir)+ forM_ (Hpack.resultWarnings r) $ \w -> $logWarn ("WARNING: " <> T.pack w)+ let cabalFile = T.pack (Hpack.resultCabalFile r)+ case Hpack.resultStatus r of+ Hpack.Generated -> $logDebug $+ "hpack generated a modified version of " <> cabalFile+ Hpack.OutputUnchanged -> $logDebug $+ "hpack output unchanged in " <> cabalFile+ -- NOTE: this is 'logInfo' so it will be outputted to the+ -- user by default.+ Hpack.AlreadyGeneratedByNewerHpack -> $logWarn $+ "WARNING: " <> cabalFile <> " was generated with a newer version of hpack, please upgrade and try again." -- | Path for the package's build log. buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m)@@ -1196,12 +1206,13 @@ -- | Extract the @PackageIdentifier@ given an exploded haskell package -- path. cabalFilePackageId- :: (Applicative m, MonadIO m, MonadThrow m)+ :: (MonadIO m, MonadThrow m) => Path Abs File -> m PackageIdentifier cabalFilePackageId fp = do pkgDescr <- liftIO (D.readPackageDescription D.silent $ toFilePath fp) (toStackPI . D.package . D.packageDescription) pkgDescr where- toStackPI (D.PackageIdentifier (D.PackageName name) ver) =- PackageIdentifier <$> parsePackageNameFromString name <*>- parseVersionFromString (showVersion ver)+ toStackPI (D.PackageIdentifier (D.PackageName name) ver) = do+ name' <- parsePackageNameFromString name+ ver' <- parseVersionFromString (showVersion ver)+ return (PackageIdentifier name' ver')
src/Stack/PackageDump.hs view
@@ -77,7 +77,7 @@ -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump- :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global@@ -87,7 +87,7 @@ -- | Call ghc-pkg describe with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDescribe- :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => PackageName -> EnvOverride -> WhichCompiler@@ -98,7 +98,7 @@ -- | Call ghc-pkg and stream to the given @Sink@, for a single database ghcPkgCmdArgs- :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => [String] -> EnvOverride -> WhichCompiler
src/Stack/PackageIndex.hs view
@@ -72,10 +72,10 @@ import System.IO (IOMode (ReadMode, WriteMode), withBinaryFile) import System.Process.Read (EnvOverride,- ReadProcessException (..), doesExecutableExist, readInNull, tryProcessStdout) import System.Process.Run (Cmd(..), callProcessInheritStderrStdout)+import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) -- | Populate the package index caches and return them. populateCache@@ -257,7 +257,7 @@ $logSticky "Fetching package index ..." let runFetch = callProcessInheritStderrStdout (Cmd (Just acfDir) "git" menv ["fetch","--tags","--depth=1"])- runFetch `C.catch` \(ex :: ReadProcessException) -> do+ runFetch `C.catch` \(ex :: ProcessExitedUnsuccessfully) -> do -- we failed, so wipe the directory and try again, see #1418 $logWarn (T.pack (show ex)) $logStickyDone "Failed to fetch package index, retrying."@@ -419,7 +419,7 @@ -- | Clear the in-memory hackage index cache. This is needed when the -- hackage index is updated.-clearPackageCaches :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)+clearPackageCaches :: (MonadIO m, MonadReader env m, HasConfig env) => m () clearPackageCaches = do cacheRef <- asks (configPackageCaches . getConfig)
src/Stack/SDist.hs view
@@ -51,7 +51,7 @@ import Stack.Build (mkBaseConfigOpts) import Stack.Build.Execute import Stack.Build.Installed-import Stack.Build.Source (loadSourceMap, getPackageConfig)+import Stack.Build.Source (loadSourceMap, getDefaultPackageConfig) import Stack.Build.Target import Stack.Constants import Stack.Package@@ -144,7 +144,7 @@ lookupVersion name = case Map.lookup name sourceMap of Just (PSLocal lp) -> Just $ packageVersion $ lpPackage lp- Just (PSUpstream version _ _) -> Just version+ Just (PSUpstream version _ _ _ _) -> Just version Nothing -> case Map.lookup name installedMap of Just (_, installed) -> Just (installedVersion installed)@@ -175,8 +175,7 @@ readLocalPackage :: M env m => Path Abs Dir -> m LocalPackage readLocalPackage pkgDir = do cabalfp <- findOrGenerateCabalFile pkgDir- name <- parsePackageNameFromFilePath cabalfp- config <- getPackageConfig defaultBuildOptsCLI name+ config <- getDefaultPackageConfig (warnings,package) <- readPackage config cabalfp mapM_ (printCabalFileWarning cabalfp) warnings return LocalPackage@@ -262,7 +261,7 @@ -- and will throw an exception in case of critical errors. -- -- Note that we temporarily decompress the archive to analyze it.-checkSDistTarball :: (MonadIO m, MonadMask m, MonadThrow m, MonadLogger m, MonadReader env m, HasEnvConfig env)+checkSDistTarball :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasEnvConfig env) => Path Abs File -- ^ Absolute path to tarball -> m () checkSDistTarball tarball = withTempTarGzContents tarball $ \pkgDir' -> do@@ -271,7 +270,7 @@ -- ^ drop ".tar" ^ drop ".gz" cabalfp <- findOrGenerateCabalFile pkgDir name <- parsePackageNameFromFilePath cabalfp- config <- getPackageConfig defaultBuildOptsCLI name+ config <- getDefaultPackageConfig (gdesc, pkgDesc) <- readPackageDescriptionDir config pkgDir $logInfo $ "Checking package '" <> packageNameText name <> "' for common mistakes"@@ -292,7 +291,7 @@ -- | Version of 'checkSDistTarball' that first saves lazy bytestring to -- temporary directory and then calls 'checkSDistTarball' on it.-checkSDistTarball' :: (MonadIO m, MonadMask m, MonadThrow m, MonadLogger m, MonadReader env m, HasEnvConfig env)+checkSDistTarball' :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasEnvConfig env) => String -- ^ Tarball name -> L.ByteString -- ^ Tarball contents as a byte string -> m ()@@ -301,7 +300,7 @@ liftIO $ L.writeFile (toFilePath npath) bytes checkSDistTarball npath -withTempTarGzContents :: (MonadIO m, MonadMask m, MonadThrow m)+withTempTarGzContents :: (MonadIO m, MonadMask m) => Path Abs File -- ^ Location of tarball -> (Path Abs Dir -> m a) -- ^ Perform actions given dir with tarball contents -> m a
src/Stack/Setup.hs view
@@ -486,7 +486,7 @@ -> m () upgradeCabal menv wc = do let name = $(mkPackageName "Cabal")- rmap <- resolvePackages menv Set.empty (Set.singleton name)+ rmap <- resolvePackages menv Map.empty (Set.singleton name) newest <- case Map.keys rmap of [] -> error "No Cabal library found in index, cannot upgrade"@@ -510,7 +510,8 @@ , T.pack $ versionString installed ] let ident = PackageIdentifier name newest- m <- unpackPackageIdents menv tmpdir Nothing (Set.singleton ident)+ -- Nothing below: use the newest .cabal file revision+ m <- unpackPackageIdents menv tmpdir Nothing (Map.singleton ident Nothing) compilerPath <- join $ findExecutable menv (compilerExeName wc) newestDir <- parseRelDir $ versionString newest@@ -711,7 +712,7 @@ sortBy (flip (comparing fst)) $ filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs_) -getGhcKey :: (MonadReader env m, MonadThrow m, HasPlatform env, HasGHCVariant env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)+getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadCatch m) => m Text getGhcKey = do ghcVariant <- asks getGHCVariant@@ -719,7 +720,7 @@ osKey <- getOSKey platform return $ osKey <> T.pack (ghcVariantSuffix ghcVariant) -getOSKey :: (MonadReader env m, MonadThrow m, HasPlatform env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)+getOSKey :: (MonadThrow m) => Platform -> m Text getOSKey platform = case platform of@@ -895,7 +896,7 @@ -- Install the downloaded stack binary distribution installDockerStackExe- :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)+ :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, MonadBaseControl IO m) => SetupInfo -> Path Abs File -> ArchiveType@@ -1012,11 +1013,11 @@ loadGhcjsEnvConfig stackYaml binPath = runInnerStackLoggingT $ do lc <- loadConfig (mempty- { configMonoidInstallGHC = Just True- , configMonoidLocalBinPath = Just (toFilePath binPath)+ { configMonoidInstallGHC = First (Just True)+ , configMonoidLocalBinPath = First (Just (toFilePath binPath)) })- (Just stackYaml) Nothing+ (Just stackYaml) bconfig <- lcLoadBuildConfig lc Nothing runInnerStackT bconfig $ setupEnv Nothing @@ -1338,7 +1339,9 @@ Map.delete "GHC_PACKAGE_PATH" . Map.delete "HASKELL_PACKAGE_SANDBOX" . Map.delete "HASKELL_PACKAGE_SANDBOXES" .- Map.delete "HASKELL_DIST_DIR"+ Map.delete "HASKELL_DIST_DIR" .+ -- https://github.com/commercialhaskell/stack/issues/1460+ Map.delete "DESTDIR" -- | Get map of environment variables to set to change the GHC's encoding to UTF-8 getUtf8EnvVars
src/Stack/Setup/Installed.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}@@ -31,6 +32,8 @@ import qualified Data.Text.Encoding as T import Distribution.System (Platform (..)) import qualified Distribution.System as Cabal+import GHC.Generics (Generic)+import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO@@ -55,7 +58,7 @@ parseToolText (parsePackageIdentifierFromString . T.unpack -> Just pkgId) = Just (Tool pkgId) parseToolText _ = Nothing -markInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)+markInstalled :: (MonadIO m, MonadThrow m) => Path Abs Dir -> Tool -> m ()@@ -63,7 +66,7 @@ fpRel <- parseRelFile $ toolString tool ++ ".installed" liftIO $ writeFile (toFilePath $ programsPath </> fpRel) "installed" -unmarkInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadCatch m)+unmarkInstalled :: (MonadIO m, MonadCatch m) => Path Abs Dir -> Tool -> m ()@@ -71,7 +74,7 @@ fpRel <- parseRelFile $ toolString tool ++ ".installed" ignoringAbsence (removeFile $ programsPath </> fpRel) -listInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)+listInstalled :: (MonadIO m, MonadThrow m) => Path Abs Dir -> m [Tool] listInstalled programsPath = do@@ -167,15 +170,12 @@ { edBins :: ![FilePath] , edInclude :: ![FilePath] , edLib :: ![FilePath]- } deriving (Show)+ } deriving (Show, Generic) instance Monoid ExtraDirs where- mempty = ExtraDirs [] [] []- mappend (ExtraDirs a b c) (ExtraDirs x y z) = ExtraDirs- (a ++ x)- (b ++ y)- (c ++ z)+ mempty = memptydefault+ mappend = mappenddefault -installDir :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)+installDir :: (MonadReader env m, MonadThrow m) => Path Abs Dir -> Tool -> m (Path Abs Dir)
src/Stack/Sig/GPG.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell #-} {-| Module : Stack.Sig.GPG@@ -15,29 +15,33 @@ module Stack.Sig.GPG (gpgSign, gpgVerify) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>), (<*>))-#endif+import Prelude ()+import Prelude.Compat +import Control.Monad (unless, when) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (MonadLogger, logWarn) import qualified Data.ByteString.Char8 as C-import Data.List (find)+import Data.List (find, isPrefixOf) import Data.Monoid ((<>)) import qualified Data.Text as T import Path import Stack.Types import System.Directory (findExecutable)+import System.Environment (lookupEnv) import System.Exit (ExitCode(..))+import System.IO (Handle, hGetContents, hPutStrLn)+import System.Info (os) import System.Process (ProcessHandle, runInteractiveProcess, waitForProcess)-import System.IO (Handle, hGetContents, hPutStrLn) -- | Sign a file path with GPG, returning the @Signature@. gpgSign- :: (MonadIO m, MonadThrow m)+ :: (MonadIO m, MonadLogger m, MonadThrow m) => Path Abs File -> m Signature gpgSign path = do+ gpgWarnTTY (_hIn,hOut,hErr,process) <- gpg [ "--output"@@ -62,7 +66,8 @@ :: (MonadIO m, MonadThrow m) => Signature -> Path Abs File -> m Fingerprint gpgVerify (Signature signature) path = do- (hIn,hOut,hErr,process) <- gpg ["--verify", "-", toFilePath path]+ (hIn,hOut,hErr,process) <-+ gpg ["--verify", "--with-fingerprint", "-", toFilePath path] (_in,out,err,code) <- liftIO ((,,,) <$>@@ -94,5 +99,19 @@ Nothing -> do mGpgPath <- liftIO (findExecutable "gpg") case mGpgPath of- Just _ -> liftIO (runInteractiveProcess "gpg" args Nothing Nothing)+ 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 :: (MonadIO m, MonadLogger m) => m ()+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 view
@@ -16,9 +16,8 @@ module Stack.Sig.Sign (sign, signPackage, signTarBytes) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..))-#endif+import Prelude ()+import Prelude.Compat import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip@@ -46,9 +45,9 @@ -- service and a path to a tarball. sign #if __GLASGOW_HASKELL__ < 710- :: (Applicative m, MonadIO m, MonadLogger m, MonadMask m, MonadThrow m)+ :: (Applicative m, MonadIO m, MonadLogger m, MonadMask m) #else- :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m)+ :: (MonadIO m, MonadLogger m, MonadMask m) #endif => Manager -> String -> Path Abs File -> m Signature sign manager url filePath =@@ -91,9 +90,9 @@ -- the tarball with GPG. signTarBytes #if __GLASGOW_HASKELL__ < 710- :: (Applicative m, MonadIO m, MonadLogger m, MonadMask m, MonadThrow m)+ :: (Applicative m, MonadIO m, MonadLogger m, MonadMask m) #else- :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m)+ :: (MonadIO m, MonadLogger m, MonadMask m) #endif => Manager -> String -> Path Rel File -> L.ByteString -> m Signature signTarBytes manager url tarPath bs =
src/Stack/Solver.hs view
@@ -12,19 +12,26 @@ , mergeConstraints , solveExtraDeps , solveResolverSpec+ -- * Internal - for tests+ , parseCabalOutputLine ) where +import Prelude ()+import Prelude.Compat+ import Control.Applicative import Control.Exception (assert) import Control.Exception.Enclosed (tryIO)+import Control.Monad (when,void,join,liftM,unless,zipWithM_) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger-import Control.Monad.Reader+import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Control import Data.Aeson.Extended ( WithJSONWarnings(..), object, (.=), toJSON , logJSONWarnings) import qualified Data.ByteString as S+import Data.Char (isSpace) import Data.Either import Data.Function (on) import qualified Data.HashMap.Strict as HashMap@@ -33,7 +40,7 @@ import Data.List.Extra (groupSortOn) import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (catMaybes, isNothing, mapMaybe)+import Data.Maybe (catMaybes, isNothing, mapMaybe, fromMaybe) import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set@@ -43,16 +50,16 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Encoding (decodeUtf8With)+import Data.Tuple (swap) import qualified Data.Yaml as Yaml import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C import qualified Distribution.Text as C import Network.HTTP.Client.Conduit (HasHttpManager)+import Text.Regex.Applicative.Text (match, sym, psym, anySym, few) import Path import Path.Find (findFiles) import Path.IO hiding (findExecutable, findFiles)-import Prelude-import Safe (headMay) import Stack.BuildPlan import Stack.Constants (stackDotYaml) import Stack.Package (printCabalFileWarning@@ -68,6 +75,7 @@ import qualified System.FilePath as FP import System.Process.Read + data ConstraintType = Constraint | Preference deriving (Eq) type ConstraintSpec = Map PackageName (Version, Map FlagName Bool) @@ -162,51 +170,17 @@ parseCabalOutput bs = do let ls = drop 1 $ dropWhile (not . T.isPrefixOf "In order, ")+ $ map stripCR $ T.lines $ decodeUtf8 bs- (errs, pairs) = partitionEithers $ map parseLine ls+ (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)) - -- An ugly parser to extract module id and flags- parseLine :: Text -> Either Text (PackageName, (Version, Map FlagName Bool))- parseLine t0 = maybe (Left t0) Right $ do- -- 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))-- if (not $ T.null t0) then do- ident':rest <- Just $ T.words t0- PackageIdentifier name version <-- parsePackageIdentifierFromString $ T.unpack ident'-- nextWord <- headMay rest- rest' <- case T.head nextWord of- '(' -> Just $ dropWhile (")" `T.isSuffixOf`) rest- '*' -> Just $ dropWhile ("*" `T.isPrefixOf`) rest- '+' -> Just rest- '-' -> Just rest- _ -> Nothing-- let fl = takeWhile (not . ("(" `T.isPrefixOf`)) rest'- flags <- mapM parseFlag fl- Just (name, (version, Map.fromList flags))- else Nothing-- parseFlag :: Text -> Maybe (FlagName, Bool)- parseFlag t0 = do- (fl, st) <- case T.head t0 of- '-' -> Just $ (T.tail t0, False)- '+' -> Just $ (T.tail t0, True)- _ -> Nothing- if (not $ T.null fl) then do- flag <- parseFlagNameFromString $ T.unpack fl- return (flag, st)- else Nothing+ stripCR t = fromMaybe t (T.stripSuffix "\r" t) toConstraintArgs userFlagMap = [formatFlagConstraint package flag enabled@@ -227,6 +201,33 @@ -- 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 :: (MonadLogger m, MonadReader env m, HasConfig env, MonadIO m, MonadThrow m) => FilePath -- ^ temp dir -> ConstraintType@@ -468,27 +469,17 @@ getResolverConstraints :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m , MonadReader env m, HasConfig env , HasGHCVariant env- , HasHttpManager env , HasLogLevel env , HasReExec env- , HasTerminal env)+ , HasHttpManager env) => Path Abs File -> Resolver -> m (CompilerVersion, Map PackageName (Version, Map FlagName Bool))-getResolverConstraints stackYaml resolver =- case resolver of- ResolverSnapshot snapName -> do- mbp <- loadMiniBuildPlan snapName- return (mbpCompilerVersion mbp, mbpConstraints mbp)- ResolverCustom _ url -> do- -- FIXME instead of passing the stackYaml dir we should maintain- -- the file URL in the custom resolver always relative to stackYaml.- mbp <- parseCustomMiniBuildPlan stackYaml url- return (mbpCompilerVersion mbp, mbpConstraints mbp)- ResolverCompiler compiler ->- return (compiler, Map.empty)- where- mpiConstraints mpi = (mpiVersion mpi, mpiFlags mpi)- mbpConstraints mbp = fmap mpiConstraints (mbpPackages mbp)+getResolverConstraints stackYaml resolver = do+ (mbp, _loadedResolver) <- loadResolver (Just stackYaml) resolver+ return (mbpCompilerVersion mbp, mbpConstraints mbp)+ where+ mpiConstraints mpi = (mpiVersion mpi, mpiFlags mpi)+ mbpConstraints mbp = fmap mpiConstraints (mbpPackages mbp) -- | Given a bundle of user packages, flag constraints on those packages and a -- resolver, determine if the resolver fully, partially or fails to satisfy the@@ -497,7 +488,7 @@ -- If the package flags are passed as 'Nothing' then flags are chosen -- automatically. checkResolverSpec- :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m+ :: ( MonadIO m, MonadMask m, MonadLogger m, MonadReader env m , HasHttpManager env, HasConfig env, HasGHCVariant env , MonadBaseControl IO m) => [C.GenericPackageDescription]@@ -515,10 +506,10 @@ -- a `hpack` `package.yaml` file exists, this will be used to generate a cabal -- file. -- Subdirectories can be included depending on the @recurse@ parameter.-findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File]-findCabalFiles recurse dir = liftIO $ do- findFiles dir isHpack subdirFilter >>= mapM_ (hpack . parent)- findFiles dir isCabal subdirFilter+findCabalFiles :: (MonadIO m, MonadLogger m) => Bool -> Path Abs Dir -> m [Path Abs File]+findCabalFiles recurse dir = do+ liftIO (findFiles dir isHpack subdirFilter) >>= mapM_ (hpack . parent)+ liftIO (findFiles dir isCabal subdirFilter) where subdirFilter subdir = recurse && not (isIgnored subdir) isHpack = (== "package.yaml") . toFilePath . filename@@ -633,9 +624,8 @@ -- extra dependencies so that the specified packages can be compiled. solveExtraDeps :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m- , MonadReader env m, HasConfig env , HasEnvConfig env, HasGHCVariant env- , HasHttpManager env , HasLogLevel env , HasReExec env- , HasTerminal env)+ , MonadReader env m, HasEnvConfig env, HasHttpManager env+ , HasLogLevel env, HasReExec env, HasTerminal env) => Bool -- ^ modify stack.yaml? -> m () solveExtraDeps modStackYaml = do@@ -661,7 +651,7 @@ (bundle, _) <- cabalPackagesCheck cabalfps noPkgMsg (Just dupPkgFooter) let gpds = Map.elems $ fmap snd bundle- oldFlags = bcFlags bconfig+ oldFlags = unPackageFlags (bcFlags bconfig) oldExtraVersions = bcExtraDeps bconfig resolver = bcResolver bconfig oldSrcs = gpdPackages gpds@@ -671,18 +661,19 @@ srcConstraints = mergeConstraints oldSrcs oldSrcFlags extraConstraints = mergeConstraints oldExtraVersions oldExtraFlags - resolverResult <- checkResolverSpec gpds (Just oldSrcFlags) resolver+ let resolver' = toResolverNotLoaded resolver+ resolverResult <- checkResolverSpec gpds (Just oldSrcFlags) resolver' resultSpecs <- case resolverResult of BuildPlanCheckOk flags -> return $ Just ((mergeConstraints oldSrcs flags), Map.empty) BuildPlanCheckPartial {} -> do eres <- solveResolverSpec stackYaml cabalDirs- (resolver, srcConstraints, extraConstraints)+ (resolver', srcConstraints, extraConstraints) -- TODO Solver should also use the init code to ignore incompatible -- packages return $ either (const Nothing) Just eres BuildPlanCheckFail {} ->- throwM $ ResolverMismatch resolver (show resolverResult)+ throwM $ ResolverMismatch IsSolverCmd resolver (show resolverResult) (srcs, edeps) <- case resultSpecs of Nothing -> throwM (SolverGiveUp giveUpMsg)
src/Stack/Types/Build.hs view
@@ -71,6 +71,7 @@ import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, (</>)) import Path.Extra (toFilePathNoTrailingSep) import Prelude+import Stack.Types.BuildPlan (GitSHA1) import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName@@ -519,14 +520,14 @@ -- | The type of a task, either building local code or something from the -- package index (upstream) data TaskType = TTLocal LocalPackage- | TTUpstream Package InstallLocation+ | TTUpstream Package InstallLocation (Maybe GitSHA1) deriving Show taskLocation :: Task -> InstallLocation taskLocation task = case taskType task of TTLocal _ -> Local- TTUpstream _ loc -> loc+ TTUpstream _ loc _ -> loc -- | A complete plan of what needs to be built and how to do it data Plan = Plan@@ -556,14 +557,13 @@ configureOpts :: EnvConfig -> BaseConfigOpts -> Map PackageIdentifier GhcPkgId -- ^ dependencies- -> Bool -- ^ wanted? -> Bool -- ^ local non-extra-dep? -> InstallLocation -> Package -> ConfigureOpts-configureOpts econfig bco deps wanted isLocal loc package = ConfigureOpts+configureOpts econfig bco deps isLocal loc package = ConfigureOpts { coDirs = configureOptsDirs bco loc package- , coNoDirs = configureOptsNoDir econfig bco deps wanted isLocal package+ , coNoDirs = configureOptsNoDir econfig bco deps isLocal package } -- options set by stack@@ -625,11 +625,10 @@ configureOptsNoDir :: EnvConfig -> BaseConfigOpts -> Map PackageIdentifier GhcPkgId -- ^ dependencies- -> Bool -- ^ wanted? -> Bool -- ^ is this a local, non-extra-dep? -> Package -> [String]-configureOptsNoDir econfig bco deps wanted isLocal package = concat+configureOptsNoDir econfig bco deps isLocal package = concat [ depOptions , ["--enable-library-profiling" | boptsLibProfile bopts || boptsExeProfile bopts] , ["--enable-executable-profiling" | boptsExeProfile bopts && isLocal]@@ -641,7 +640,7 @@ else "-") <> flagNameString name) (Map.toList flags)- , concatMap (\x -> ["--ghc-options", T.unpack x]) allGhcOptions+ , concatMap (\x -> ["--ghc-options", T.unpack x]) (packageGhcOptions package) , map (("--extra-include-dirs=" ++) . T.unpack) (Set.toList (configExtraIncludeDirs config)) , map (("--extra-lib-dirs=" ++) . T.unpack) (Set.toList (configExtraLibDirs config)) , if whichCompiler (envConfigCompilerVersion econfig) == Ghcjs@@ -652,7 +651,6 @@ where config = getConfig econfig bopts = bcoBuildOpts bco- boptsCli = bcoBuildOptsCLI bco -- TODO: instead always enable this when the cabal version is new -- enough. That way we'll detect bugs with --exact-configuration@@ -685,24 +683,6 @@ ] where PackageIdentifier name version = ident-- allGhcOptions = concat- [ Map.findWithDefault [] Nothing (configGhcOptions config)- , Map.findWithDefault [] (Just $ packageName package) (configGhcOptions config)- , concat [["-fhpc"] | isLocal && toCoverage (boptsTestOpts bopts)]- , if (boptsLibProfile bopts || boptsExeProfile bopts)- then ["-auto-all","-caf-all"]- else []- , if includeExtraOptions- then boptsCLIGhcOptions boptsCli- else []- ]-- includeExtraOptions =- case configApplyGhcOptions config of- AGOTargets -> wanted- AGOLocals -> isLocal- AGOEverything -> True -- | Get set of wanted package names from locals. wantedLocalPackages :: [LocalPackage] -> Set PackageName
src/Stack/Types/BuildPlan.hs view
@@ -21,8 +21,12 @@ , SnapName (..) , MiniBuildPlan (..) , MiniPackageInfo (..)+ , CabalFileInfo (..)+ , GitSHA1 (..) , renderSnapName , parseSnapName+ , SnapshotHash (..)+ , trimmedSnapshotHash ) where import Control.Applicative@@ -33,6 +37,8 @@ object, withObject, withText, (.!=), (.:), (.:?), (.=)) import Data.Binary.VersionTagged+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap import Data.IntMap (IntMap)@@ -101,6 +107,7 @@ data PackagePlan = PackagePlan { ppVersion :: Version+ , ppCabalFileInfo :: Maybe CabalFileInfo , ppGithubPings :: Set Text , ppUsers :: Set PackageName , ppConstraints :: PackageConstraints@@ -110,6 +117,7 @@ instance ToJSON PackagePlan where toJSON PackagePlan {..} = object+ $ maybe id (\cfi -> (("cabal-file-info" .= cfi):)) ppCabalFileInfo $ [ "version" .= ppVersion , "github-pings" .= ppGithubPings , "users" .= ppUsers@@ -119,12 +127,32 @@ instance FromJSON PackagePlan where parseJSON = withObject "PackageBuild" $ \o -> do ppVersion <- o .: "version"+ ppCabalFileInfo <- o .:? "cabal-file-info" ppGithubPings <- o .:? "github-pings" .!= mempty ppUsers <- o .:? "users" .!= mempty ppConstraints <- o .: "constraints" ppDesc <- o .: "description" return PackagePlan {..} +-- | Information on the contents of a cabal file+data CabalFileInfo = CabalFileInfo+ { cfiSize :: !Int+ -- ^ File size in bytes+ , cfiHashes :: !(Map.Map Text Text)+ -- ^ Various hashes of the file contents+ }+ deriving (Show, Eq, Generic)+instance ToJSON CabalFileInfo where+ toJSON CabalFileInfo {..} = object+ [ "size" .= cfiSize+ , "hashes" .= cfiHashes+ ]+instance FromJSON CabalFileInfo where+ parseJSON = withObject "CabalFileInfo" $ \o -> do+ cfiSize <- o .: "size"+ cfiHashes <- o .: "hashes"+ return CabalFileInfo {..}+ display :: DT.Text a => a -> Text display = fromString . DT.display @@ -410,6 +438,7 @@ data MiniPackageInfo = MiniPackageInfo { mpiVersion :: !Version , mpiFlags :: !(Map FlagName Bool)+ , mpiGhcOptions :: ![Text] , mpiPackageDeps :: !(Set PackageName) , mpiToolDeps :: !(Set Text) -- ^ Due to ambiguity in Cabal, it is unclear whether this refers to the@@ -420,8 +449,21 @@ -- ^ Executables provided by this package , mpiHasLibrary :: !Bool -- ^ Is there a library present?+ , mpiGitSHA1 :: !(Maybe GitSHA1)+ -- ^ An optional SHA1 representation in hex format of the blob containing+ -- the cabal file contents. Useful for grabbing the correct cabal file+ -- revision directly from a Git repo } deriving (Generic, Show, Eq) instance Binary MiniPackageInfo instance HasStructuralInfo MiniPackageInfo instance NFData MiniPackageInfo++newtype GitSHA1 = GitSHA1 ByteString+ deriving (Generic, Show, Eq, NFData, HasStructuralInfo, Binary)++newtype SnapshotHash = SnapshotHash { unShapshotHash :: ByteString }+ deriving (Generic, Show, Eq)++trimmedSnapshotHash :: SnapshotHash -> ByteString+trimmedSnapshotHash = BS.take 12 . unShapshotHash
src/Stack/Types/Config.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiWayIf #-}@@ -10,6 +11,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-} -- | The Config type. @@ -31,6 +35,7 @@ ,BuildConfig(..) ,bcRoot ,bcWorkDir+ ,bcWantedCompiler ,HasBuildConfig(..) -- ** GHCVariant & HasGHCVariant ,GHCVariant(..)@@ -49,6 +54,8 @@ ,ApplyGhcOptions(..) -- ** ConfigException ,ConfigException(..)+ -- ** WhichSolverCmd+ ,WhichSolverCmd(..) -- ** ConfigMonoid ,ConfigMonoid(..) -- ** EnvSettings@@ -72,6 +79,7 @@ ,configPackageIndexCache ,configPackageIndexGz ,configPackageIndexRoot+ ,configPackageIndexRepo ,configPackageTarball ,indexNameText ,IndexLocation(..)@@ -82,12 +90,24 @@ ,PvpBounds(..) ,parsePvpBounds -- ** Resolver & AbstractResolver- ,Resolver(..)+ ,Resolver+ ,LoadedResolver+ ,ResolverThat's(..) ,parseResolverText+ ,resolverDirName ,resolverName+ ,customResolverHash+ ,toResolverNotLoaded ,AbstractResolver(..) -- ** SCM ,SCM(..)+ -- ** CustomSnapshot+ ,CustomSnapshot(..)+ -- ** GhcOptions+ ,GhcOptions(..)+ ,ghcOptionsFor+ -- ** PackageFlags+ ,PackageFlags(..) -- * Paths ,bindirSuffix ,configInstalledCache@@ -150,7 +170,7 @@ import qualified Data.Map as Map import qualified Data.Map.Strict as M import Data.Maybe-import Data.Monoid+import Data.Monoid.Extra import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text)@@ -161,10 +181,12 @@ import Distribution.System (Platform) import qualified Distribution.Text import Distribution.Version (anyVersion)+import GHC.Generics (Generic)+import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Network.HTTP.Client (parseUrl) import Path import qualified Paths_stack as Meta-import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName)+import Stack.Types.BuildPlan (MiniBuildPlan(..), SnapName, renderSnapName, parseSnapName, SnapshotHash (..), trimmedSnapshotHash) import Stack.Types.Urls import Stack.Types.Compiler import Stack.Types.Docker@@ -176,6 +198,7 @@ import Stack.Types.PackageName import Stack.Types.TemplateName import Stack.Types.Version+import System.FilePath (takeBaseName) import System.PosixCompat.Types (UserID, GroupID, FileMode) import System.Process.Read (EnvOverride, findExecutable) @@ -263,8 +286,6 @@ -- ^ --extra-include-dirs arguments ,configExtraLibDirs :: !(Set Text) -- ^ --extra-lib-dirs arguments- ,configConfigMonoid :: !ConfigMonoid- -- ^ @ConfigMonoid@ used to generate this ,configConcurrentTests :: !Bool -- ^ Run test suites concurrently ,configImage :: !ImageOpts@@ -272,7 +293,7 @@ -- ^ Parameters for templates. ,configScmInit :: !(Maybe SCM) -- ^ Initialize SCM (e.g. git) when creating new projects.- ,configGhcOptions :: !(Map (Maybe PackageName) [Text])+ ,configGhcOptions :: !GhcOptions -- ^ Additional GHC options to apply to either all packages (Nothing) -- or a specific package (Just). ,configSetupInfoLocations :: ![SetupInfoLocation]@@ -423,29 +444,20 @@ -- | Parsed global command-line options monoid. data GlobalOptsMonoid = GlobalOptsMonoid- { globalMonoidReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version- , globalMonoidDockerEntrypoint :: !(Maybe DockerEntrypoint)+ { 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 :: !(Maybe LogLevel) -- ^ Log level+ , globalMonoidLogLevel :: !(First LogLevel) -- ^ Log level , globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'- , globalMonoidResolver :: !(Maybe AbstractResolver) -- ^ Resolver override- , globalMonoidCompiler :: !(Maybe CompilerVersion) -- ^ Compiler override- , globalMonoidTerminal :: !(Maybe Bool) -- ^ We're in a terminal?- , globalMonoidStackYaml :: !(Maybe FilePath) -- ^ Override project stack.yaml- } deriving (Show)+ , globalMonoidResolver :: !(First AbstractResolver) -- ^ Resolver override+ , globalMonoidCompiler :: !(First CompilerVersion) -- ^ Compiler override+ , globalMonoidTerminal :: !(First Bool) -- ^ We're in a terminal?+ , globalMonoidStackYaml :: !(First FilePath) -- ^ Override project stack.yaml+ } deriving (Show, Generic) instance Monoid GlobalOptsMonoid where- mempty = GlobalOptsMonoid Nothing Nothing Nothing mempty Nothing Nothing Nothing Nothing- mappend l r = GlobalOptsMonoid- { globalMonoidReExecVersion = globalMonoidReExecVersion l <|> globalMonoidReExecVersion r- , globalMonoidDockerEntrypoint =- globalMonoidDockerEntrypoint l <|> globalMonoidDockerEntrypoint r- , globalMonoidLogLevel = globalMonoidLogLevel l <|> globalMonoidLogLevel r- , globalMonoidConfigMonoid = globalMonoidConfigMonoid l <> globalMonoidConfigMonoid r- , globalMonoidResolver = globalMonoidResolver l <|> globalMonoidResolver r- , globalMonoidCompiler = globalMonoidCompiler l <|> globalMonoidCompiler r- , globalMonoidTerminal = globalMonoidTerminal l <|> globalMonoidTerminal r- , globalMonoidStackYaml = globalMonoidStackYaml l <|> globalMonoidStackYaml r }+ mempty = memptydefault+ mappend = mappenddefault -- | Either an actual resolver value, or an abstract description of one (e.g., -- latest nightly).@@ -466,10 +478,10 @@ -- 'Config' in order to determine the values here. data BuildConfig = BuildConfig { bcConfig :: !Config- , bcResolver :: !Resolver+ , bcResolver :: !LoadedResolver -- ^ How we resolve which dependencies to install given a set of -- packages.- , bcWantedCompiler :: !CompilerVersion+ , bcWantedMiniBuildPlan :: !MiniBuildPlan -- ^ Compiler version wanted for this build , bcPackageEntries :: ![PackageEntry] -- ^ Local packages@@ -485,7 +497,7 @@ -- -- Note: if the STACK_YAML environment variable is used, this may be -- different from bcRoot </> "stack.yaml"- , bcFlags :: !(Map PackageName (Map FlagName Bool))+ , bcFlags :: !PackageFlags -- ^ Per-package flag overrides , bcImplicitGlobal :: !Bool -- ^ Are we loading from the implicit global stack.yaml? This is useful@@ -504,6 +516,9 @@ workDir <- getWorkDir return (bcRoot bconfig </> workDir) +bcWantedCompiler :: BuildConfig -> CompilerVersion+bcWantedCompiler = mbpCompilerVersion . bcWantedMiniBuildPlan+ -- | Configuration after the environment has been setup. data EnvConfig = EnvConfig {envConfigBuildConfig :: !BuildConfig@@ -620,7 +635,7 @@ , projectExtraDeps :: !(Map PackageName Version) -- ^ Components of the package list referring to package/version combos, -- see: https://github.com/fpco/stack/issues/41- , projectFlags :: !(Map PackageName (Map FlagName Bool))+ , projectFlags :: !PackageFlags -- ^ Per-package flag overrides , projectResolver :: !Resolver -- ^ How we resolve which dependencies to use@@ -641,29 +656,48 @@ , "extra-package-dbs" .= projectExtraPackageDBs p ]) --- | How we resolve which dependencies to install given a set of packages.-data Resolver- = ResolverSnapshot SnapName- -- ^ Use an official snapshot from the Stackage project, either an LTS- -- Haskell or Stackage Nightly+data IsLoaded = Loaded | NotLoaded - | ResolverCompiler !CompilerVersion- -- ^ 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.+type LoadedResolver = ResolverThat's 'Loaded+type Resolver = ResolverThat's 'NotLoaded - | ResolverCustom !Text !Text- -- ^ A custom resolver based on the given name and URL. This file is assumed- -- to be completely immutable.- deriving (Show)+-- TODO: once GHC 8.0 is the lowest version we support, make these into+-- actual haddock comments... -instance ToJSON Resolver where- toJSON (ResolverCustom name location) = object- [ "name" .= name- , "location" .= location- ]- toJSON x = toJSON $ resolverName x-instance FromJSON (WithJSONWarnings Resolver) where+-- | How we resolve which dependencies to install given a set of packages.+data ResolverThat's (l :: IsLoaded) where+ -- Use an official snapshot from the Stackage project, either an LTS+ -- Haskell or Stackage Nightly.+ ResolverSnapshot :: !SnapName -> ResolverThat's l+ -- Require a specific compiler version, but otherwise provide no+ -- build plan. Intended for use cases where end user wishes to+ -- specify all upstream dependencies manually, such as using a+ -- dependency solver.+ ResolverCompiler :: !CompilerVersion -> ResolverThat's l+ -- A custom resolver based on the given name and URL. When a URL is+ -- provided, it file is to be completely immutable. Filepaths are+ -- always loaded. This constructor is used before the build-plan has+ -- been loaded, as we do not yet know the custom snapshot's hash.+ ResolverCustom :: !Text -> !Text -> ResolverThat's 'NotLoaded+ -- Like 'ResolverCustom', but after loading the build-plan, so we+ -- have a hash. This is necessary in order to identify the location+ -- files are stored for the resolver.+ ResolverCustomLoaded :: !Text -> !Text -> !SnapshotHash -> ResolverThat's 'Loaded++deriving instance Show (ResolverThat's k)++instance ToJSON (ResolverThat's k) where+ toJSON x = case x of+ ResolverSnapshot{} -> toJSON $ resolverName x+ ResolverCompiler{} -> toJSON $ resolverName x+ ResolverCustom n l -> handleCustom n l+ ResolverCustomLoaded n l _ -> handleCustom n l+ where+ handleCustom n l = object+ [ "name" .= n+ , "location" .= l+ ]+instance FromJSON (WithJSONWarnings (ResolverThat's 'NotLoaded)) where -- Strange structuring is to give consistent error messages parseJSON v@(Object _) = withObjectWarnings "Resolver" (\o -> ResolverCustom <$> o ..: "name"@@ -675,11 +709,23 @@ -- | Convert a Resolver into its @Text@ representation, as will be used by -- directory names-resolverName :: Resolver -> Text+resolverDirName :: LoadedResolver -> Text+resolverDirName (ResolverSnapshot name) = renderSnapName name+resolverDirName (ResolverCompiler v) = compilerVersionText v+resolverDirName (ResolverCustomLoaded name _ hash) = "custom-" <> name <> "-" <> decodeUtf8 (trimmedSnapshotHash hash)++-- | Convert a Resolver into its @Text@ representation for human+-- presentation.+resolverName :: ResolverThat's l -> Text resolverName (ResolverSnapshot name) = renderSnapName name resolverName (ResolverCompiler v) = compilerVersionText v resolverName (ResolverCustom name _) = "custom-" <> name+resolverName (ResolverCustomLoaded name _ _) = "custom-" <> name +customResolverHash :: LoadedResolver-> Maybe SnapshotHash+customResolverHash (ResolverCustomLoaded _ _ hash) = Just hash+customResolverHash _ = Nothing+ -- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom). parseResolverText :: MonadThrow m => Text -> m Resolver parseResolverText t@@ -687,6 +733,12 @@ | Just v <- parseCompilerVersion t = return $ ResolverCompiler v | otherwise = throwM $ ParseResolverException t +toResolverNotLoaded :: LoadedResolver -> Resolver+toResolverNotLoaded r = case r of+ ResolverSnapshot s -> ResolverSnapshot s+ ResolverCompiler v -> ResolverCompiler v+ ResolverCustomLoaded n l _ -> ResolverCustom n l+ -- | Class for environment values which have access to the stack root class HasStackRoot env where getStackRoot :: env -> Path Abs Dir@@ -744,9 +796,9 @@ -- Configurations may be "cascaded" using mappend (left-biased). data ConfigMonoid = ConfigMonoid- { configMonoidStackRoot :: !(Maybe (Path Abs Dir))+ { configMonoidStackRoot :: !(First (Path Abs Dir)) -- ^ See: 'configStackRoot'- , configMonoidWorkDir :: !(Maybe FilePath)+ , configMonoidWorkDir :: !(First FilePath) -- ^ See: 'configWorkDir'. , configMonoidBuildOpts :: !BuildOptsMonoid -- ^ build options.@@ -754,159 +806,80 @@ -- ^ Docker options. , configMonoidNixOpts :: !NixOptsMonoid -- ^ Options for the execution environment (nix-shell or container)- , configMonoidConnectionCount :: !(Maybe Int)+ , configMonoidConnectionCount :: !(First Int) -- ^ See: 'configConnectionCount'- , configMonoidHideTHLoading :: !(Maybe Bool)+ , configMonoidHideTHLoading :: !(First Bool) -- ^ See: 'configHideTHLoading'- , configMonoidLatestSnapshotUrl :: !(Maybe Text)+ , configMonoidLatestSnapshotUrl :: !(First Text) -- ^ Deprecated in favour of 'urlsMonoidLatestSnapshot' , configMonoidUrls :: !UrlsMonoid -- ^ See: 'configUrls- , configMonoidPackageIndices :: !(Maybe [PackageIndex])+ , configMonoidPackageIndices :: !(First [PackageIndex]) -- ^ See: 'configPackageIndices'- , configMonoidSystemGHC :: !(Maybe Bool)+ , configMonoidSystemGHC :: !(First Bool) -- ^ See: 'configSystemGHC'- ,configMonoidInstallGHC :: !(Maybe Bool)+ ,configMonoidInstallGHC :: !(First Bool) -- ^ See: 'configInstallGHC'- ,configMonoidSkipGHCCheck :: !(Maybe Bool)+ ,configMonoidSkipGHCCheck :: !(First Bool) -- ^ See: 'configSkipGHCCheck'- ,configMonoidSkipMsys :: !(Maybe Bool)+ ,configMonoidSkipMsys :: !(First Bool) -- ^ See: 'configSkipMsys'- ,configMonoidCompilerCheck :: !(Maybe VersionCheck)+ ,configMonoidCompilerCheck :: !(First VersionCheck) -- ^ See: 'configCompilerCheck'- ,configMonoidRequireStackVersion :: !VersionRange+ ,configMonoidRequireStackVersion :: !IntersectingVersionRange -- ^ See: 'configRequireStackVersion'- ,configMonoidOS :: !(Maybe String)+ ,configMonoidOS :: !(First String) -- ^ Used for overriding the platform- ,configMonoidArch :: !(Maybe String)+ ,configMonoidArch :: !(First String) -- ^ Used for overriding the platform- ,configMonoidGHCVariant :: !(Maybe GHCVariant)+ ,configMonoidGHCVariant :: !(First GHCVariant) -- ^ Used for overriding the GHC variant- ,configMonoidJobs :: !(Maybe Int)+ ,configMonoidJobs :: !(First Int) -- ^ See: 'configJobs' ,configMonoidExtraIncludeDirs :: !(Set Text) -- ^ See: 'configExtraIncludeDirs' ,configMonoidExtraLibDirs :: !(Set Text) -- ^ See: 'configExtraLibDirs'- ,configMonoidConcurrentTests :: !(Maybe Bool)+ ,configMonoidConcurrentTests :: !(First Bool) -- ^ See: 'configConcurrentTests'- ,configMonoidLocalBinPath :: !(Maybe FilePath)+ ,configMonoidLocalBinPath :: !(First FilePath) -- ^ Used to override the binary installation dir ,configMonoidImageOpts :: !ImageOptsMonoid -- ^ Image creation options. ,configMonoidTemplateParameters :: !(Map Text Text) -- ^ Template parameters.- ,configMonoidScmInit :: !(Maybe SCM)+ ,configMonoidScmInit :: !(First SCM) -- ^ Initialize SCM (e.g. git init) when making new projects?- ,configMonoidGhcOptions :: !(Map (Maybe PackageName) [Text])+ ,configMonoidGhcOptions :: !GhcOptions -- ^ See 'configGhcOptions' ,configMonoidExtraPath :: ![Path Abs Dir] -- ^ Additional paths to search for executables in ,configMonoidSetupInfoLocations :: ![SetupInfoLocation] -- ^ Additional setup info (inline or remote) to use for installing tools- ,configMonoidPvpBounds :: !(Maybe PvpBounds)+ ,configMonoidPvpBounds :: !(First PvpBounds) -- ^ See 'configPvpBounds'- ,configMonoidModifyCodePage :: !(Maybe Bool)+ ,configMonoidModifyCodePage :: !(First Bool) -- ^ See 'configModifyCodePage' ,configMonoidExplicitSetupDeps :: !(Map (Maybe PackageName) Bool) -- ^ See 'configExplicitSetupDeps'- ,configMonoidRebuildGhcOptions :: !(Maybe Bool)+ ,configMonoidRebuildGhcOptions :: !(First Bool) -- ^ See 'configMonoidRebuildGhcOptions'- ,configMonoidApplyGhcOptions :: !(Maybe ApplyGhcOptions)+ ,configMonoidApplyGhcOptions :: !(First ApplyGhcOptions) -- ^ See 'configApplyGhcOptions'- ,configMonoidAllowNewer :: !(Maybe Bool)+ ,configMonoidAllowNewer :: !(First Bool) -- ^ See 'configMonoidAllowNewer'- ,configMonoidDefaultTemplate :: !(Maybe TemplateName)+ ,configMonoidDefaultTemplate :: !(First TemplateName) -- ^ The default template to use when none is specified. -- (If Nothing, the default default is used.)- , configMonoidAllowDifferentUser :: !(Maybe Bool)+ , configMonoidAllowDifferentUser :: !(First Bool) -- ^ Allow users other than the stack root owner to use the stack -- installation. }- deriving Show+ deriving (Show, Generic) instance Monoid ConfigMonoid where- mempty = ConfigMonoid- { configMonoidStackRoot = Nothing- , configMonoidWorkDir = Nothing- , configMonoidBuildOpts = mempty- , configMonoidDockerOpts = mempty- , configMonoidNixOpts = mempty- , configMonoidConnectionCount = Nothing- , configMonoidHideTHLoading = Nothing- , configMonoidLatestSnapshotUrl = Nothing- , configMonoidUrls = mempty- , configMonoidPackageIndices = Nothing- , configMonoidSystemGHC = Nothing- , configMonoidInstallGHC = Nothing- , configMonoidSkipGHCCheck = Nothing- , configMonoidSkipMsys = Nothing- , configMonoidRequireStackVersion = anyVersion- , configMonoidOS = Nothing- , configMonoidArch = Nothing- , configMonoidGHCVariant = Nothing- , configMonoidJobs = Nothing- , configMonoidExtraIncludeDirs = Set.empty- , configMonoidExtraLibDirs = Set.empty- , configMonoidConcurrentTests = Nothing- , configMonoidLocalBinPath = Nothing- , configMonoidImageOpts = mempty- , configMonoidTemplateParameters = mempty- , configMonoidScmInit = Nothing- , configMonoidCompilerCheck = Nothing- , configMonoidGhcOptions = mempty- , configMonoidExtraPath = []- , configMonoidSetupInfoLocations = mempty- , configMonoidPvpBounds = Nothing- , configMonoidModifyCodePage = Nothing- , configMonoidExplicitSetupDeps = mempty- , configMonoidRebuildGhcOptions = Nothing- , configMonoidApplyGhcOptions = Nothing- , configMonoidAllowNewer = Nothing- , configMonoidDefaultTemplate = Nothing- , configMonoidAllowDifferentUser = Nothing- }- mappend l r = ConfigMonoid- { configMonoidStackRoot = configMonoidStackRoot l <|> configMonoidStackRoot r- , configMonoidWorkDir = configMonoidWorkDir l <|> configMonoidWorkDir r- , configMonoidBuildOpts = configMonoidBuildOpts l <> configMonoidBuildOpts r- , configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r- , configMonoidNixOpts = configMonoidNixOpts l <> configMonoidNixOpts r- , configMonoidConnectionCount = configMonoidConnectionCount l <|> configMonoidConnectionCount r- , configMonoidHideTHLoading = configMonoidHideTHLoading l <|> configMonoidHideTHLoading r- , configMonoidLatestSnapshotUrl = configMonoidLatestSnapshotUrl l <|> configMonoidLatestSnapshotUrl r- , configMonoidUrls = configMonoidUrls l <> configMonoidUrls r- , configMonoidPackageIndices = configMonoidPackageIndices l <|> configMonoidPackageIndices r- , configMonoidSystemGHC = configMonoidSystemGHC l <|> configMonoidSystemGHC r- , configMonoidInstallGHC = configMonoidInstallGHC l <|> configMonoidInstallGHC r- , configMonoidSkipGHCCheck = configMonoidSkipGHCCheck l <|> configMonoidSkipGHCCheck r- , configMonoidSkipMsys = configMonoidSkipMsys l <|> configMonoidSkipMsys r- , configMonoidRequireStackVersion = intersectVersionRanges (configMonoidRequireStackVersion l)- (configMonoidRequireStackVersion r)- , configMonoidOS = configMonoidOS l <|> configMonoidOS r- , configMonoidArch = configMonoidArch l <|> configMonoidArch r- , configMonoidGHCVariant = configMonoidGHCVariant l <|> configMonoidGHCVariant r- , configMonoidJobs = configMonoidJobs l <|> configMonoidJobs r- , configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r)- , configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r)- , configMonoidConcurrentTests = configMonoidConcurrentTests l <|> configMonoidConcurrentTests r- , configMonoidLocalBinPath = configMonoidLocalBinPath l <|> configMonoidLocalBinPath r- , configMonoidImageOpts = configMonoidImageOpts l <> configMonoidImageOpts r- , configMonoidTemplateParameters = configMonoidTemplateParameters l <> configMonoidTemplateParameters r- , configMonoidScmInit = configMonoidScmInit l <|> configMonoidScmInit r- , configMonoidCompilerCheck = configMonoidCompilerCheck l <|> configMonoidCompilerCheck r- , configMonoidGhcOptions = Map.unionWith (++) (configMonoidGhcOptions l) (configMonoidGhcOptions r)- , configMonoidExtraPath = configMonoidExtraPath l ++ configMonoidExtraPath r- , configMonoidSetupInfoLocations = configMonoidSetupInfoLocations l ++ configMonoidSetupInfoLocations r- , configMonoidPvpBounds = configMonoidPvpBounds l <|> configMonoidPvpBounds r- , configMonoidModifyCodePage = configMonoidModifyCodePage l <|> configMonoidModifyCodePage r- , configMonoidExplicitSetupDeps = configMonoidExplicitSetupDeps l <> configMonoidExplicitSetupDeps r- , configMonoidRebuildGhcOptions = configMonoidRebuildGhcOptions l <|> configMonoidRebuildGhcOptions r- , configMonoidApplyGhcOptions = configMonoidApplyGhcOptions l <|> configMonoidApplyGhcOptions r- , configMonoidAllowNewer = configMonoidAllowNewer l <|> configMonoidAllowNewer r- , configMonoidDefaultTemplate = configMonoidDefaultTemplate l <|> configMonoidDefaultTemplate r- , configMonoidAllowDifferentUser = configMonoidAllowDifferentUser l <|> configMonoidAllowDifferentUser r- }+ mempty = memptydefault+ mappend = mappenddefault instance FromJSON (WithJSONWarnings ConfigMonoid) where parseJSON = withObjectWarnings "ConfigMonoid" parseConfigMonoidJSON@@ -917,47 +890,43 @@ parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid parseConfigMonoidJSON obj = do -- Parsing 'stackRoot' from 'stackRoot'/config.yaml would be nonsensical- let configMonoidStackRoot = Nothing- configMonoidWorkDir <- obj ..:? configMonoidWorkDirName+ let configMonoidStackRoot = First Nothing+ configMonoidWorkDir <- First <$> obj ..:? configMonoidWorkDirName configMonoidBuildOpts <- jsonSubWarnings (obj ..:? configMonoidBuildOptsName ..!= mempty) configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty) configMonoidNixOpts <- jsonSubWarnings (obj ..:? configMonoidNixOptsName ..!= mempty)- configMonoidConnectionCount <- obj ..:? configMonoidConnectionCountName- configMonoidHideTHLoading <- obj ..:? configMonoidHideTHLoadingName- configMonoidLatestSnapshotUrl <- obj ..:? configMonoidLatestSnapshotUrlName+ configMonoidConnectionCount <- First <$> obj ..:? configMonoidConnectionCountName+ configMonoidHideTHLoading <- First <$> obj ..:? configMonoidHideTHLoadingName+ configMonoidLatestSnapshotUrl <- First <$> obj ..:? configMonoidLatestSnapshotUrlName configMonoidUrls <- jsonSubWarnings (obj ..:? configMonoidUrlsName ..!= mempty)- configMonoidPackageIndices <- jsonSubWarningsTT (obj ..:? configMonoidPackageIndicesName)- configMonoidSystemGHC <- obj ..:? configMonoidSystemGHCName- configMonoidInstallGHC <- obj ..:? configMonoidInstallGHCName- configMonoidSkipGHCCheck <- obj ..:? configMonoidSkipGHCCheckName- configMonoidSkipMsys <- obj ..:? configMonoidSkipMsysName- configMonoidRequireStackVersion <- unVersionRangeJSON <$>+ 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- configMonoidOS <- obj ..:? configMonoidOSName- configMonoidArch <- obj ..:? configMonoidArchName- configMonoidGHCVariant <- obj ..:? configMonoidGHCVariantName- configMonoidJobs <- obj ..:? configMonoidJobsName+ configMonoidOS <- First <$> obj ..:? configMonoidOSName+ configMonoidArch <- First <$> obj ..:? configMonoidArchName+ configMonoidGHCVariant <- First <$> obj ..:? configMonoidGHCVariantName+ configMonoidJobs <- First <$> obj ..:? configMonoidJobsName configMonoidExtraIncludeDirs <- obj ..:? configMonoidExtraIncludeDirsName ..!= Set.empty configMonoidExtraLibDirs <- obj ..:? configMonoidExtraLibDirsName ..!= Set.empty- configMonoidConcurrentTests <- obj ..:? configMonoidConcurrentTestsName- configMonoidLocalBinPath <- obj ..:? configMonoidLocalBinPathName+ configMonoidConcurrentTests <- First <$> obj ..:? configMonoidConcurrentTestsName+ configMonoidLocalBinPath <- First <$> obj ..:? configMonoidLocalBinPathName configMonoidImageOpts <- jsonSubWarnings (obj ..:? configMonoidImageOptsName ..!= mempty) templates <- obj ..:? "templates" (configMonoidScmInit,configMonoidTemplateParameters) <- case templates of- Nothing -> return (Nothing,M.empty)+ Nothing -> return (First Nothing,M.empty) Just tobj -> do scmInit <- tobj ..:? configMonoidScmInitName params <- tobj ..:? configMonoidTemplateParametersName- return (scmInit,fromMaybe M.empty params)- configMonoidCompilerCheck <- obj ..:? configMonoidCompilerCheckName+ return (First scmInit,fromMaybe M.empty params)+ configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName - mghcoptions <- obj ..:? configMonoidGhcOptionsName- configMonoidGhcOptions <-- case mghcoptions of- Nothing -> return mempty- Just m -> fmap Map.fromList $ mapM handleGhcOptions $ Map.toList m+ configMonoidGhcOptions <- obj ..:? configMonoidGhcOptionsName ..!= mempty extraPath <- obj ..:? configMonoidExtraPathName ..!= [] configMonoidExtraPath <- forM extraPath $@@ -965,32 +934,19 @@ configMonoidSetupInfoLocations <- maybeToList <$> jsonSubWarningsT (obj ..:? configMonoidSetupInfoLocationsName)- configMonoidPvpBounds <- obj ..:? configMonoidPvpBoundsName- configMonoidModifyCodePage <- obj ..:? configMonoidModifyCodePageName+ configMonoidPvpBounds <- First <$> obj ..:? configMonoidPvpBoundsName+ configMonoidModifyCodePage <- First <$> obj ..:? configMonoidModifyCodePageName configMonoidExplicitSetupDeps <- (obj ..:? configMonoidExplicitSetupDepsName ..!= mempty) >>= fmap Map.fromList . mapM handleExplicitSetupDep . Map.toList- configMonoidRebuildGhcOptions <- obj ..:? configMonoidRebuildGhcOptionsName- configMonoidApplyGhcOptions <- obj ..:? configMonoidApplyGhcOptionsName- configMonoidAllowNewer <- obj ..:? configMonoidAllowNewerName- configMonoidDefaultTemplate <- obj ..:? configMonoidDefaultTemplateName- configMonoidAllowDifferentUser <- obj ..:? configMonoidAllowDifferentUserName+ configMonoidRebuildGhcOptions <- First <$> obj ..:? configMonoidRebuildGhcOptionsName+ configMonoidApplyGhcOptions <- First <$> obj ..:? configMonoidApplyGhcOptionsName+ configMonoidAllowNewer <- First <$> obj ..:? configMonoidAllowNewerName+ configMonoidDefaultTemplate <- First <$> obj ..:? configMonoidDefaultTemplateName+ configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName return ConfigMonoid {..} where- handleGhcOptions :: Monad m => (Text, Text) -> m (Maybe PackageName, [Text])- handleGhcOptions (name', vals') = do- name <-- if name' == "*"- then return Nothing- else case parsePackageNameFromString $ T.unpack name' of- Left e -> fail $ show e- Right x -> return $ Just x-- case parseArgs Escaping vals' of- Left e -> fail e- Right vals -> return (name, map T.pack vals)- handleExplicitSetupDep :: Monad m => (Text, Bool) -> m (Maybe PackageName, Bool) handleExplicitSetupDep (name', b) = do name <-@@ -1114,14 +1070,15 @@ data ConfigException = ParseConfigFileException (Path Abs File) ParseException+ | ParseCustomSnapshotException Text ParseException | ParseResolverException Text | NoProjectConfigFound (Path Abs Dir) (Maybe Text) | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File] | UnableToExtractArchive Text (Path Abs File) | BadStackVersionException VersionRange- | NoMatchingSnapshot (NonEmpty SnapName)- | ResolverMismatch Resolver String- | ResolverPartial Resolver String+ | NoMatchingSnapshot WhichSolverCmd (NonEmpty SnapName)+ | forall l. ResolverMismatch WhichSolverCmd (ResolverThat's l) String+ | ResolverPartial WhichSolverCmd Resolver String | NoSuchDirectory FilePath | ParseGHCVariantException String | BadStackRoot (Path Abs Dir)@@ -1136,6 +1093,14 @@ , show exception , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/." ]+ show (ParseCustomSnapshotException url exception) = concat+ [ "Could not parse '"+ , T.unpack url+ , "':\n"+ , show exception+ -- FIXME: Link to docs about custom snapshots+ -- , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/."+ ] show (ParseResolverException t) = concat [ "Invalid resolver value: " , T.unpack t@@ -1168,31 +1133,27 @@ ,"version range specified in stack.yaml (" , T.unpack (versionRangeText requiredRange) , ")." ]- show (NoMatchingSnapshot names) = concat+ 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)- , "\nYou can try the following options:\n"- , " - Use '--omit-packages to exclude mismatching package(s).\n"- , " - Use '--resolver' to specify a matching snapshot/resolver\n"+ , showOptions whichCmd ]- show (ResolverMismatch resolver errDesc) = concat+ show (ResolverMismatch whichCmd resolver errDesc) = concat [ "Resolver '" , T.unpack (resolverName resolver) , "' does not have a matching compiler to build some or all of your " , "package(s).\n" , errDesc- , "\nHowever, you can try '--omit-packages to exclude mismatching "- , "package(s)."+ , showOptions whichCmd ]- show (ResolverPartial resolver errDesc) = concat+ show (ResolverPartial whichCmd resolver errDesc) = concat [ "Resolver '" , T.unpack (resolverName resolver) , "' does not have all the packages to match your requirements.\n" , unlines $ fmap (" " <>) (lines errDesc)- , "\nHowever, you can try '--solver' to use external packages."- , "\nUse '--omit-packages' if you want to create a config anyway."+ , showOptions whichCmd ] show (NoSuchDirectory dir) = concat ["No directory could be located matching the supplied path: "@@ -1224,6 +1185,20 @@ ] instance Exception ConfigException +showOptions :: WhichSolverCmd -> String+showOptions whichCmd = unlines $ ["\nThis may be resolved by:"] ++ options+ where+ options =+ case whichCmd of+ IsSolverCmd -> [useResolver]+ IsInitCmd -> both+ IsNewCmd -> both+ both = [omitPackages, useResolver]+ omitPackages = " - Using '--omit-packages to exclude mismatching package(s)."+ useResolver = " - Using '--resolver' to specify a matching snapshot/resolver"++data WhichSolverCmd = IsInitCmd | IsSolverCmd | IsNewCmd+ -- | Helper function to ask the environment and apply getConfig askConfig :: (MonadReader env m, HasConfig env) => m Config askConfig = liftM getConfig ask@@ -1239,6 +1214,29 @@ dir <- parseRelDir $ S8.unpack name return (configStackRoot config </> $(mkRelDir "indices") </> dir) +-- | Git repo directory for a specific package index, returns 'Nothing' if not+-- a Git repo+configPackageIndexRepo :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Maybe (Path Abs Dir))+configPackageIndexRepo name = do+ indices <- asks $ configPackageIndices . getConfig+ case filter (\p -> indexName p == name) indices of+ [index] -> do+ let murl =+ case indexLocation index of+ ILGit x -> Just x+ ILHttp _ -> Nothing+ ILGitHttp x _ -> Just x+ case murl of+ Nothing -> return Nothing+ Just url -> do+ sDir <- configPackageIndexRoot name+ repoName <- parseRelDir $ takeBaseName $ T.unpack url+ let suDir =+ sDir </>+ $(mkRelDir "git-update")+ return $ Just $ suDir </> repoName+ _ -> assert False $ return Nothing+ -- | Location of the 00-index.cache file configPackageIndexCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) configPackageIndexCache = liftM (</> $(mkRelFile "00-index.cache")) . configPackageIndexRoot@@ -1309,12 +1307,12 @@ -- | Path for platform followed by snapshot name followed by compiler -- name. platformSnapAndCompilerRel- :: (MonadReader env m, HasPlatform env, HasEnvConfig env, MonadThrow m)+ :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Rel Dir) platformSnapAndCompilerRel = do bc <- asks getBuildConfig platform <- platformGhcRelDir- name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc+ name <- parseRelDir $ T.unpack $ resolverDirName $ bcResolver bc ghc <- compilerVersionDir useShaPathOnWindows (platform </> name </> ghc) @@ -1711,3 +1709,79 @@ , duGroups :: [GroupID] -- ^ Supplemantal groups , duUmask :: FileMode -- ^ File creation mask } } deriving (Read,Show)++-- TODO: See section of+-- https://github.com/commercialhaskell/stack/issues/1265 about+-- rationalizing the config. It would also be nice to share more code.+-- For now it's more convenient just to extend this type. However, it's+-- unpleasant that it has overlap with both 'Project' and 'Config'.+data CustomSnapshot = CustomSnapshot+ { csCompilerVersion :: !(Maybe CompilerVersion)+ , csPackages :: !(Set PackageIdentifier)+ , csDropPackages :: !(Set PackageName)+ , csFlags :: !PackageFlags+ , csGhcOptions :: !GhcOptions+ }++instance FromJSON (WithJSONWarnings (CustomSnapshot, Maybe Resolver)) where+ parseJSON = withObjectWarnings "CustomSnapshot" $ \o -> (,)+ <$> (CustomSnapshot+ <$> o ..:? "compiler"+ <*> o ..:? "packages" ..!= mempty+ <*> o ..:? "drop-packages" ..!= mempty+ <*> o ..:? "flags" ..!= mempty+ <*> o ..:? configMonoidGhcOptionsName ..!= mempty)+ <*> jsonSubWarningsT (o ..:? "resolver")++newtype GhcOptions = GhcOptions+ { unGhcOptions :: Map (Maybe PackageName) [Text] }+ deriving Show++instance FromJSON GhcOptions where+ parseJSON val = do+ ghcOptions <- parseJSON val+ fmap (GhcOptions . Map.fromList) $ mapM handleGhcOptions $ Map.toList ghcOptions+ where+ handleGhcOptions :: Monad m => (Text, Text) -> m (Maybe PackageName, [Text])+ handleGhcOptions (name', vals') = do+ name <-+ if name' == "*"+ then return Nothing+ else case parsePackageNameFromString $ T.unpack name' of+ Left e -> fail $ show e+ Right x -> return $ Just x++ case parseArgs Escaping vals' of+ Left e -> fail e+ Right vals -> return (name, map T.pack vals)++instance Monoid GhcOptions where+ mempty = GhcOptions mempty+ -- FIXME: Should GhcOptions really monoid like this? Keeping it this+ -- way preserves the behavior of the ConfigMonoid. However, this+ -- means there isn't the ability to fully override snapshot+ -- ghc-options in the same way there is for flags. Do we want to+ -- change the semantics here? (particularly for extensible+ -- snapshots)+ mappend (GhcOptions l) (GhcOptions r) =+ GhcOptions (Map.unionWith (++) l r)++ghcOptionsFor :: PackageName -> GhcOptions -> [Text]+ghcOptionsFor name (GhcOptions mp) =+ M.findWithDefault [] Nothing mp +++ M.findWithDefault [] (Just name) mp++newtype PackageFlags = PackageFlags+ { unPackageFlags :: Map PackageName (Map FlagName Bool) }+ deriving Show++instance FromJSON PackageFlags where+ parseJSON val = PackageFlags <$> parseJSON val++instance ToJSON PackageFlags where+ toJSON = toJSON . unPackageFlags++instance Monoid PackageFlags where+ mempty = PackageFlags mempty+ mappend (PackageFlags l) (PackageFlags r) =+ PackageFlags (Map.unionWith Map.union l r)
src/Stack/Types/Config/Build.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE FlexibleInstances, RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} -- | Configuration options for building. @@ -13,6 +16,9 @@ , TestOpts(..) , defaultTestOpts , TestOptsMonoid(..)+ , HaddockOpts(..)+ , defaultHaddockOpts+ , HaddockOptsMonoid(..) , BenchmarkOpts(..) , defaultBenchmarkOpts , BenchmarkOptsMonoid(..)@@ -21,14 +27,17 @@ ) where +import Control.Applicative import Data.Aeson.Extended import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Monoid import Data.Text (Text)+import GHC.Generics (Generic)+import Generics.Deriving.Monoid (memptydefault, mappenddefault)+import Prelude -- Fix AMP warning import Stack.Types.FlagName import Stack.Types.PackageName-import Control.Applicative -- | Build options that is interpreted by the build command. -- This is built up from BuildOptsCLI and BuildOptsMonoid@@ -37,6 +46,8 @@ ,boptsExeProfile :: !Bool ,boptsHaddock :: !Bool -- ^ Build haddocks?+ ,boptsHaddockOpts :: !HaddockOpts+ -- ^ Options to pass to haddock ,boptsOpenHaddocks :: !Bool -- ^ Open haddocks in the browser? ,boptsHaddockDeps :: !(Maybe Bool)@@ -76,6 +87,7 @@ { boptsLibProfile = False , boptsExeProfile = False , boptsHaddock = False+ , boptsHaddockOpts = defaultHaddockOpts , boptsOpenHaddocks = False , boptsHaddockDeps = Nothing , boptsInstallExes = False@@ -128,42 +140,44 @@ -- | Build options that may be specified in the stack.yaml or from the CLI data BuildOptsMonoid = BuildOptsMonoid- { buildMonoidLibProfile :: !(Maybe Bool)- , buildMonoidExeProfile :: !(Maybe Bool)- , buildMonoidHaddock :: !(Maybe Bool)- , buildMonoidOpenHaddocks :: !(Maybe Bool)- , buildMonoidHaddockDeps :: !(Maybe Bool)- , buildMonoidInstallExes :: !(Maybe Bool)- , buildMonoidPreFetch :: !(Maybe Bool)- , buildMonoidKeepGoing :: !(Maybe Bool)- , buildMonoidForceDirty :: !(Maybe Bool)- , buildMonoidTests :: !(Maybe Bool)+ { buildMonoidLibProfile :: !(First Bool)+ , buildMonoidExeProfile :: !(First Bool)+ , buildMonoidHaddock :: !(First Bool)+ , buildMonoidHaddockOpts :: !HaddockOptsMonoid+ , buildMonoidOpenHaddocks :: !(First Bool)+ , buildMonoidHaddockDeps :: !(First Bool)+ , buildMonoidInstallExes :: !(First Bool)+ , buildMonoidPreFetch :: !(First Bool)+ , buildMonoidKeepGoing :: !(First Bool)+ , buildMonoidForceDirty :: !(First Bool)+ , buildMonoidTests :: !(First Bool) , buildMonoidTestOpts :: !TestOptsMonoid- , buildMonoidBenchmarks :: !(Maybe Bool)+ , buildMonoidBenchmarks :: !(First Bool) , buildMonoidBenchmarkOpts :: !BenchmarkOptsMonoid- , buildMonoidReconfigure :: !(Maybe Bool)- , buildMonoidCabalVerbose :: !(Maybe Bool)- , buildMonoidSplitObjs :: !(Maybe Bool)- } deriving (Show)+ , buildMonoidReconfigure :: !(First Bool)+ , buildMonoidCabalVerbose :: !(First Bool)+ , buildMonoidSplitObjs :: !(First Bool)+ } deriving (Show, Generic) instance FromJSON (WithJSONWarnings BuildOptsMonoid) where parseJSON = withObjectWarnings "BuildOptsMonoid"- (\o -> do buildMonoidLibProfile <- o ..:? buildMonoidLibProfileArgName- buildMonoidExeProfile <- o ..:? buildMonoidExeProfileArgName- buildMonoidHaddock <- o ..:? buildMonoidHaddockArgName- buildMonoidOpenHaddocks <- o ..:? buildMonoidOpenHaddocksArgName- buildMonoidHaddockDeps <- o ..:? buildMonoidHaddockDepsArgName- buildMonoidInstallExes <- o ..:? buildMonoidInstallExesArgName- buildMonoidPreFetch <- o ..:? buildMonoidPreFetchArgName- buildMonoidKeepGoing <- o ..:? buildMonoidKeepGoingArgName- buildMonoidForceDirty <- o ..:? buildMonoidForceDirtyArgName- buildMonoidTests <- o ..:? buildMonoidTestsArgName+ (\o -> do buildMonoidLibProfile <- First <$> o ..:? buildMonoidLibProfileArgName+ buildMonoidExeProfile <-First <$> o ..:? buildMonoidExeProfileArgName+ buildMonoidHaddock <- First <$> o ..:? buildMonoidHaddockArgName+ buildMonoidHaddockOpts <- jsonSubWarnings (o ..:? buildMonoidHaddockOptsArgName ..!= mempty)+ buildMonoidOpenHaddocks <- First <$> o ..:? buildMonoidOpenHaddocksArgName+ buildMonoidHaddockDeps <- First <$> o ..:? buildMonoidHaddockDepsArgName+ buildMonoidInstallExes <- First <$> o ..:? buildMonoidInstallExesArgName+ buildMonoidPreFetch <- First <$> o ..:? buildMonoidPreFetchArgName+ buildMonoidKeepGoing <- First <$> o ..:? buildMonoidKeepGoingArgName+ buildMonoidForceDirty <- First <$> o ..:? buildMonoidForceDirtyArgName+ buildMonoidTests <- First <$> o ..:? buildMonoidTestsArgName buildMonoidTestOpts <- jsonSubWarnings (o ..:? buildMonoidTestOptsArgName ..!= mempty)- buildMonoidBenchmarks <- o ..:? buildMonoidBenchmarksArgName+ buildMonoidBenchmarks <- First <$> o ..:? buildMonoidBenchmarksArgName buildMonoidBenchmarkOpts <- jsonSubWarnings (o ..:? buildMonoidBenchmarkOptsArgName ..!= mempty)- buildMonoidReconfigure <- o ..:? buildMonoidReconfigureArgName- buildMonoidCabalVerbose <- o ..:? buildMonoidCabalVerboseArgName- buildMonoidSplitObjs <- o ..:? buildMonoidSplitObjsName+ buildMonoidReconfigure <- First <$> o ..:? buildMonoidReconfigureArgName+ buildMonoidCabalVerbose <- First <$> o ..:? buildMonoidCabalVerboseArgName+ buildMonoidSplitObjs <- First <$> o ..:? buildMonoidSplitObjsName return BuildOptsMonoid{..}) buildMonoidLibProfileArgName :: Text@@ -175,6 +189,9 @@ buildMonoidHaddockArgName :: Text buildMonoidHaddockArgName = "haddock" +buildMonoidHaddockOptsArgName :: Text+buildMonoidHaddockOptsArgName = "haddock-arguments"+ buildMonoidOpenHaddocksArgName :: Text buildMonoidOpenHaddocksArgName = "open-haddocks" @@ -215,43 +232,8 @@ buildMonoidSplitObjsName = "split-objs" instance Monoid BuildOptsMonoid where- mempty = BuildOptsMonoid- {buildMonoidLibProfile = Nothing- ,buildMonoidExeProfile = Nothing- ,buildMonoidHaddock = Nothing- ,buildMonoidOpenHaddocks = Nothing- ,buildMonoidHaddockDeps = Nothing- ,buildMonoidInstallExes = Nothing- ,buildMonoidPreFetch = Nothing- ,buildMonoidKeepGoing = Nothing- ,buildMonoidForceDirty = Nothing- ,buildMonoidTests = Nothing- ,buildMonoidTestOpts = mempty- ,buildMonoidBenchmarks = Nothing- ,buildMonoidBenchmarkOpts = mempty- ,buildMonoidReconfigure = Nothing- ,buildMonoidCabalVerbose = Nothing- ,buildMonoidSplitObjs = Nothing- }-- mappend l r = BuildOptsMonoid- {buildMonoidLibProfile = buildMonoidLibProfile l <|> buildMonoidLibProfile r- ,buildMonoidExeProfile = buildMonoidExeProfile l <|> buildMonoidExeProfile r- ,buildMonoidHaddock = buildMonoidHaddock l <|> buildMonoidHaddock r- ,buildMonoidOpenHaddocks = buildMonoidOpenHaddocks l <|> buildMonoidOpenHaddocks r- ,buildMonoidHaddockDeps = buildMonoidHaddockDeps l <|> buildMonoidHaddockDeps r- ,buildMonoidInstallExes = buildMonoidInstallExes l <|> buildMonoidInstallExes r- ,buildMonoidPreFetch = buildMonoidPreFetch l <|> buildMonoidPreFetch r- ,buildMonoidKeepGoing = buildMonoidKeepGoing l <|> buildMonoidKeepGoing r- ,buildMonoidForceDirty = buildMonoidForceDirty l <|> buildMonoidForceDirty r- ,buildMonoidTests = buildMonoidTests l <|> buildMonoidTests r- ,buildMonoidTestOpts = buildMonoidTestOpts l <> buildMonoidTestOpts r- ,buildMonoidBenchmarks = buildMonoidBenchmarks l <|> buildMonoidBenchmarks r- ,buildMonoidBenchmarkOpts = buildMonoidBenchmarkOpts l <> buildMonoidBenchmarkOpts r- ,buildMonoidReconfigure = buildMonoidReconfigure l <|> buildMonoidReconfigure r- ,buildMonoidCabalVerbose = buildMonoidCabalVerbose l <|> buildMonoidCabalVerbose r- ,buildMonoidSplitObjs = buildMonoidSplitObjs l <|> buildMonoidSplitObjs r- }+ mempty = memptydefault+ mappend = mappenddefault -- | Which subset of packages to build data BuildSubset@@ -280,18 +262,18 @@ data TestOptsMonoid = TestOptsMonoid- { toMonoidRerunTests :: !(Maybe Bool)+ { toMonoidRerunTests :: !(First Bool) , toMonoidAdditionalArgs :: ![String]- , toMonoidCoverage :: !(Maybe Bool)- , toMonoidDisableRun :: !(Maybe Bool)- } deriving (Show)+ , toMonoidCoverage :: !(First Bool)+ , toMonoidDisableRun :: !(First Bool)+ } deriving (Show, Generic) instance FromJSON (WithJSONWarnings TestOptsMonoid) where parseJSON = withObjectWarnings "TestOptsMonoid"- (\o -> do toMonoidRerunTests <- o ..:? toMonoidRerunTestsArgName+ (\o -> do toMonoidRerunTests <- First <$> o ..:? toMonoidRerunTestsArgName toMonoidAdditionalArgs <- o ..:? toMonoidAdditionalArgsName ..!= []- toMonoidCoverage <- o ..:? toMonoidCoverageArgName- toMonoidDisableRun <- o ..:? toMonoidDisableRunArgName+ toMonoidCoverage <- First <$> o ..:? toMonoidCoverageArgName+ toMonoidDisableRun <- First <$> o ..:? toMonoidDisableRunArgName return TestOptsMonoid{..}) toMonoidRerunTestsArgName :: Text@@ -307,19 +289,36 @@ toMonoidDisableRunArgName = "no-run-tests" instance Monoid TestOptsMonoid where- mempty = TestOptsMonoid- { toMonoidRerunTests = Nothing- , toMonoidAdditionalArgs = []- , toMonoidCoverage = Nothing- , toMonoidDisableRun = Nothing- }- mappend l r = TestOptsMonoid- { toMonoidRerunTests = toMonoidRerunTests l <|> toMonoidRerunTests r- , toMonoidAdditionalArgs = toMonoidAdditionalArgs l <> toMonoidAdditionalArgs r- , toMonoidCoverage = toMonoidCoverage l <|> toMonoidCoverage r- , toMonoidDisableRun = toMonoidDisableRun l <|> toMonoidDisableRun r- }+ mempty = memptydefault+ mappend = mappenddefault +++-- | Haddock Options+data HaddockOpts =+ HaddockOpts { toHaddockArgs :: ![String] -- ^ Arguments passed to haddock program+ } deriving (Eq,Show)++data HaddockOptsMonoid =+ HaddockOptsMonoid {toMonoidHaddockArgs :: ![String]+ } deriving (Show, Generic)++defaultHaddockOpts :: HaddockOpts+defaultHaddockOpts = HaddockOpts {toHaddockArgs = []}++instance FromJSON (WithJSONWarnings HaddockOptsMonoid) where+ parseJSON = withObjectWarnings "HaddockOptsMonoid"+ (\o -> do toMonoidHaddockArgs <- o ..:? toMonoidHaddockArgsName ..!= []+ return HaddockOptsMonoid{..})++instance Monoid HaddockOptsMonoid where+ mempty = memptydefault+ mappend = mappenddefault++toMonoidHaddockArgsName :: Text+toMonoidHaddockArgsName = "haddock-args"++ -- | Options for the 'FinalAction' 'DoBenchmarks' data BenchmarkOpts = BenchmarkOpts@@ -335,14 +334,14 @@ data BenchmarkOptsMonoid = BenchmarkOptsMonoid- { beoMonoidAdditionalArgs :: !(Maybe String)- , beoMonoidDisableRun :: !(Maybe Bool)- } deriving (Show)+ { beoMonoidAdditionalArgs :: !(First String)+ , beoMonoidDisableRun :: !(First Bool)+ } deriving (Show, Generic) instance FromJSON (WithJSONWarnings BenchmarkOptsMonoid) where parseJSON = withObjectWarnings "BenchmarkOptsMonoid"- (\o -> do beoMonoidAdditionalArgs <- o ..:? beoMonoidAdditionalArgsArgName- beoMonoidDisableRun <- o ..:? beoMonoidDisableRunArgName+ (\o -> do beoMonoidAdditionalArgs <- First <$> o ..:? beoMonoidAdditionalArgsArgName+ beoMonoidDisableRun <- First <$> o ..:? beoMonoidDisableRunArgName return BenchmarkOptsMonoid{..}) beoMonoidAdditionalArgsArgName :: Text@@ -352,12 +351,8 @@ beoMonoidDisableRunArgName = "no-run-benchmarks" instance Monoid BenchmarkOptsMonoid where- mempty = BenchmarkOptsMonoid- { beoMonoidAdditionalArgs = Nothing- , beoMonoidDisableRun = Nothing}- mappend l r = BenchmarkOptsMonoid- { beoMonoidAdditionalArgs = beoMonoidAdditionalArgs l <|> beoMonoidAdditionalArgs r- , beoMonoidDisableRun = beoMonoidDisableRun l <|> beoMonoidDisableRun r}+ mempty = memptydefault+ mappend = mappenddefault data FileWatchOpts = NoFileWatch
src/Stack/Types/Docker.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} -- | Docker types. @@ -13,6 +16,8 @@ import qualified Data.Text as T import Distribution.Text (simpleParse) import Distribution.Version (anyVersion)+import GHC.Generics (Generic)+import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Path import Stack.Types.Version @@ -58,26 +63,26 @@ -- | An uninterpreted representation of docker options. -- Configurations may be "cascaded" using mappend (left-biased). data DockerOptsMonoid = DockerOptsMonoid- {dockerMonoidDefaultEnable :: !Bool+ {dockerMonoidDefaultEnable :: !Any -- ^ Should Docker be defaulted to enabled (does @docker:@ section exist in the config)?- ,dockerMonoidEnable :: !(Maybe Bool)+ ,dockerMonoidEnable :: !(First Bool) -- ^ Is using Docker enabled?- ,dockerMonoidRepoOrImage :: !(Maybe DockerMonoidRepoOrImage)+ ,dockerMonoidRepoOrImage :: !(First DockerMonoidRepoOrImage) -- ^ Docker repository name (e.g. @fpco/stack-build@ or @fpco/stack-full:lts-2.8@)- ,dockerMonoidRegistryLogin :: !(Maybe Bool)+ ,dockerMonoidRegistryLogin :: !(First Bool) -- ^ Does registry require login for pulls?- ,dockerMonoidRegistryUsername :: !(Maybe String)+ ,dockerMonoidRegistryUsername :: !(First String) -- ^ Optional username for Docker registry.- ,dockerMonoidRegistryPassword :: !(Maybe String)+ ,dockerMonoidRegistryPassword :: !(First String) -- ^ Optional password for Docker registry.- ,dockerMonoidAutoPull :: !(Maybe Bool)+ ,dockerMonoidAutoPull :: !(First Bool) -- ^ Automatically pull new images.- ,dockerMonoidDetach :: !(Maybe Bool)+ ,dockerMonoidDetach :: !(First Bool) -- ^ Whether to run a detached container- ,dockerMonoidPersist :: !(Maybe Bool)+ ,dockerMonoidPersist :: !(First Bool) -- ^ Create a persistent container (don't remove it when finished). Implied by -- `dockerDetach`.- ,dockerMonoidContainerName :: !(Maybe String)+ ,dockerMonoidContainerName :: !(First String) -- ^ Container name to use, only makes sense from command-line with `dockerPersist` -- or `dockerDetach`. ,dockerMonoidRunArgs :: ![String]@@ -86,86 +91,49 @@ -- ^ Volumes to mount in the container ,dockerMonoidEnv :: ![String] -- ^ Environment variables to set in the container- ,dockerMonoidDatabasePath :: !(Maybe String)+ ,dockerMonoidDatabasePath :: !(First String) -- ^ Location of image usage database.- ,dockerMonoidStackExe :: !(Maybe String)+ ,dockerMonoidStackExe :: !(First String) -- ^ Location of container-compatible stack executable- ,dockerMonoidSetUser :: !(Maybe Bool)+ ,dockerMonoidSetUser :: !(First Bool) -- ^ Set in-container user to match host's- ,dockerMonoidRequireDockerVersion :: !VersionRange+ ,dockerMonoidRequireDockerVersion :: !IntersectingVersionRange -- ^ See: 'dockerRequireDockerVersion' }- deriving (Show)+ deriving (Show, Generic) -- | Decode uninterpreted docker options from JSON/YAML. instance FromJSON (WithJSONWarnings DockerOptsMonoid) where parseJSON = withObjectWarnings "DockerOptsMonoid"- (\o -> do dockerMonoidDefaultEnable <- pure True- dockerMonoidEnable <- o ..:? dockerEnableArgName- dockerMonoidRepoOrImage <- ((Just . DockerMonoidImage) <$> o ..: dockerImageArgName) <|>+ (\o -> do dockerMonoidDefaultEnable <- pure (Any True)+ dockerMonoidEnable <- First <$> o ..:? dockerEnableArgName+ dockerMonoidRepoOrImage <- First <$>+ (((Just . DockerMonoidImage) <$> o ..: dockerImageArgName) <|> ((Just . DockerMonoidRepo) <$> o ..: dockerRepoArgName) <|>- pure Nothing- dockerMonoidRegistryLogin <- o ..:? dockerRegistryLoginArgName- dockerMonoidRegistryUsername <- o ..:? dockerRegistryUsernameArgName- dockerMonoidRegistryPassword <- o ..:? dockerRegistryPasswordArgName- dockerMonoidAutoPull <- o ..:? dockerAutoPullArgName- dockerMonoidDetach <- o ..:? dockerDetachArgName- dockerMonoidPersist <- o ..:? dockerPersistArgName- dockerMonoidContainerName <- o ..:? dockerContainerNameArgName+ pure Nothing)+ dockerMonoidRegistryLogin <- First <$> o ..:? dockerRegistryLoginArgName+ dockerMonoidRegistryUsername <- First <$> o ..:? dockerRegistryUsernameArgName+ dockerMonoidRegistryPassword <- First <$> o ..:? dockerRegistryPasswordArgName+ dockerMonoidAutoPull <- First <$> o ..:? dockerAutoPullArgName+ dockerMonoidDetach <- First <$> o ..:? dockerDetachArgName+ dockerMonoidPersist <- First <$> o ..:? dockerPersistArgName+ dockerMonoidContainerName <- First <$> o ..:? dockerContainerNameArgName dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= [] dockerMonoidMount <- o ..:? dockerMountArgName ..!= [] dockerMonoidEnv <- o ..:? dockerEnvArgName ..!= []- dockerMonoidDatabasePath <- o ..:? dockerDatabasePathArgName- dockerMonoidStackExe <- o ..:? dockerStackExeArgName- dockerMonoidSetUser <- o ..:? dockerSetUserArgName+ dockerMonoidDatabasePath <- First <$> o ..:? dockerDatabasePathArgName+ dockerMonoidStackExe <- First <$> o ..:? dockerStackExeArgName+ dockerMonoidSetUser <- First <$> o ..:? dockerSetUserArgName dockerMonoidRequireDockerVersion- <- unVersionRangeJSON <$>+ <- IntersectingVersionRange <$> unVersionRangeJSON <$> o ..:? dockerRequireDockerVersionArgName ..!= VersionRangeJSON anyVersion return DockerOptsMonoid{..}) -- | Left-biased combine Docker options instance Monoid DockerOptsMonoid where- mempty = DockerOptsMonoid- {dockerMonoidDefaultEnable = False- ,dockerMonoidEnable = Nothing- ,dockerMonoidRepoOrImage = Nothing- ,dockerMonoidRegistryLogin = Nothing- ,dockerMonoidRegistryUsername = Nothing- ,dockerMonoidRegistryPassword = Nothing- ,dockerMonoidAutoPull = Nothing- ,dockerMonoidDetach = Nothing- ,dockerMonoidPersist = Nothing- ,dockerMonoidContainerName = Nothing- ,dockerMonoidRunArgs = []- ,dockerMonoidMount = []- ,dockerMonoidEnv = []- ,dockerMonoidDatabasePath = Nothing- ,dockerMonoidStackExe = Nothing- ,dockerMonoidSetUser = Nothing- ,dockerMonoidRequireDockerVersion = anyVersion- }- mappend l r = DockerOptsMonoid- {dockerMonoidDefaultEnable = dockerMonoidDefaultEnable l || dockerMonoidDefaultEnable r- ,dockerMonoidEnable = dockerMonoidEnable l <|> dockerMonoidEnable r- ,dockerMonoidRepoOrImage = dockerMonoidRepoOrImage l <|> dockerMonoidRepoOrImage r- ,dockerMonoidRegistryLogin = dockerMonoidRegistryLogin l <|> dockerMonoidRegistryLogin r- ,dockerMonoidRegistryUsername = dockerMonoidRegistryUsername l <|> dockerMonoidRegistryUsername r- ,dockerMonoidRegistryPassword = dockerMonoidRegistryPassword l <|> dockerMonoidRegistryPassword r- ,dockerMonoidAutoPull = dockerMonoidAutoPull l <|> dockerMonoidAutoPull r- ,dockerMonoidDetach = dockerMonoidDetach l <|> dockerMonoidDetach r- ,dockerMonoidPersist = dockerMonoidPersist l <|> dockerMonoidPersist r- ,dockerMonoidContainerName = dockerMonoidContainerName l <|> dockerMonoidContainerName r- ,dockerMonoidRunArgs = dockerMonoidRunArgs r <> dockerMonoidRunArgs l- ,dockerMonoidMount = dockerMonoidMount r <> dockerMonoidMount l- ,dockerMonoidEnv = dockerMonoidEnv r <> dockerMonoidEnv l- ,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r- ,dockerMonoidStackExe = dockerMonoidStackExe l <|> dockerMonoidStackExe r- ,dockerMonoidSetUser = dockerMonoidSetUser l <|> dockerMonoidSetUser r- ,dockerMonoidRequireDockerVersion- = intersectVersionRanges (dockerMonoidRequireDockerVersion l)- (dockerMonoidRequireDockerVersion r)- }+ mempty = memptydefault+ mappend = mappenddefault -- | Where to get the `stack` executable to run in Docker containers data DockerStackExe
src/Stack/Types/Image.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -11,6 +12,8 @@ import qualified Data.Map as Map import Data.Maybe (maybeToList) import Data.Text (Text)+import GHC.Generics (Generic)+import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Prelude -- Fix redundant import warnings -- | Image options. Currently only Docker image options.@@ -37,7 +40,7 @@ data ImageOptsMonoid = ImageOptsMonoid { imgMonoidDockers :: ![ImageDockerOpts]- } deriving (Show)+ } deriving (Show, Generic) instance FromJSON (WithJSONWarnings ImageOptsMonoid) where parseJSON = withObjectWarnings@@ -52,12 +55,8 @@ }) instance Monoid ImageOptsMonoid where- mempty = ImageOptsMonoid- { imgMonoidDockers = []- }- mappend l r = ImageOptsMonoid- { imgMonoidDockers = imgMonoidDockers l <> imgMonoidDockers r- }+ mempty = memptydefault+ mappend = mappenddefault instance FromJSON (WithJSONWarnings ImageDockerOpts) where parseJSON = withObjectWarnings
src/Stack/Types/Internal.hs view
@@ -6,6 +6,7 @@ import Control.Concurrent.MVar import Control.Monad.Logger (LogLevel)+import Data.Monoid.Extra import Data.Text (Text) import Lens.Micro import Network.HTTP.Client.Conduit (Manager,HasHttpManager(..))@@ -80,21 +81,21 @@ (\s t -> s {envConfig = t}) buildOptsMonoidHaddock :: Lens' BuildOptsMonoid (Maybe Bool)-buildOptsMonoidHaddock = lens (buildMonoidHaddock)- (\buildMonoid t -> buildMonoid {buildMonoidHaddock = t})+buildOptsMonoidHaddock = lens (getFirst . buildMonoidHaddock)+ (\buildMonoid t -> buildMonoid {buildMonoidHaddock = First t}) buildOptsMonoidTests :: Lens' BuildOptsMonoid (Maybe Bool)-buildOptsMonoidTests = lens (buildMonoidTests)- (\buildMonoid t -> buildMonoid {buildMonoidTests = t})+buildOptsMonoidTests = lens (getFirst . buildMonoidTests)+ (\buildMonoid t -> buildMonoid {buildMonoidTests = First t}) buildOptsMonoidBenchmarks :: Lens' BuildOptsMonoid (Maybe Bool)-buildOptsMonoidBenchmarks = lens (buildMonoidBenchmarks)- (\buildMonoid t -> buildMonoid {buildMonoidBenchmarks = t})+buildOptsMonoidBenchmarks = lens (getFirst . buildMonoidBenchmarks)+ (\buildMonoid t -> buildMonoid {buildMonoidBenchmarks = First t}) buildOptsMonoidInstallExes :: Lens' BuildOptsMonoid (Maybe Bool) buildOptsMonoidInstallExes =- lens (buildMonoidInstallExes)- (\buildMonoid t -> buildMonoid {buildMonoidInstallExes = t})+ lens (getFirst . buildMonoidInstallExes)+ (\buildMonoid t -> buildMonoid {buildMonoidInstallExes = First t}) buildOptsInstallExes :: Lens' BuildOpts Bool buildOptsInstallExes =
src/Stack/Types/Nix.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -10,6 +11,8 @@ import Data.Aeson.Extended import Data.Text (Text) import Data.Monoid+import GHC.Generics (Generic)+import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Prelude -- | Nix configuration. Parameterize by resolver type to avoid cyclic@@ -29,55 +32,39 @@ -- | An uninterpreted representation of nix options. -- Configurations may be "cascaded" using mappend (left-biased). data NixOptsMonoid = NixOptsMonoid- {nixMonoidDefaultEnable :: !Bool+ {nixMonoidDefaultEnable :: !Any -- ^ Should nix-shell be defaulted to enabled (does @nix:@ section exist in the config)?- ,nixMonoidEnable :: !(Maybe Bool)+ ,nixMonoidEnable :: !(First Bool) -- ^ Is using nix-shell enabled?- ,nixMonoidPureShell :: !(Maybe Bool)+ ,nixMonoidPureShell :: !(First Bool) -- ^ Should the nix-shell be pure- ,nixMonoidPackages :: !(Maybe [Text])+ ,nixMonoidPackages :: !(First [Text]) -- ^ System packages to use (given to nix-shell)- ,nixMonoidInitFile :: !(Maybe FilePath)+ ,nixMonoidInitFile :: !(First FilePath) -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix)- ,nixMonoidShellOptions :: !(Maybe [Text])+ ,nixMonoidShellOptions :: !(First [Text]) -- ^ Options to be given to the nix-shell command line- ,nixMonoidPath :: !(Maybe [Text])+ ,nixMonoidPath :: !(First [Text]) -- ^ Override parts of NIX_PATH (notably 'nixpkgs') }- deriving (Eq, Show)+ deriving (Eq, Show, Generic) -- | Decode uninterpreted nix options from JSON/YAML. instance FromJSON (WithJSONWarnings NixOptsMonoid) where parseJSON = withObjectWarnings "NixOptsMonoid"- (\o -> do nixMonoidDefaultEnable <- pure False- nixMonoidEnable <- o ..:? nixEnableArgName- nixMonoidPureShell <- o ..:? nixPureShellArgName- nixMonoidPackages <- o ..:? nixPackagesArgName- nixMonoidInitFile <- o ..:? nixInitFileArgName- nixMonoidShellOptions <- o ..:? nixShellOptsArgName- nixMonoidPath <- o ..:? nixPathArgName+ (\o -> do nixMonoidDefaultEnable <- pure (Any False)+ nixMonoidEnable <- First <$> o ..:? nixEnableArgName+ nixMonoidPureShell <- First <$> o ..:? nixPureShellArgName+ nixMonoidPackages <- First <$> o ..:? nixPackagesArgName+ nixMonoidInitFile <- First <$> o ..:? nixInitFileArgName+ nixMonoidShellOptions <- First <$> o ..:? nixShellOptsArgName+ nixMonoidPath <- First <$> o ..:? nixPathArgName return NixOptsMonoid{..}) -- | Left-biased combine Nix options instance Monoid NixOptsMonoid where- mempty = NixOptsMonoid- {nixMonoidDefaultEnable = False- ,nixMonoidEnable = Nothing- ,nixMonoidPureShell = Nothing- ,nixMonoidPackages = Nothing- ,nixMonoidInitFile = Nothing- ,nixMonoidShellOptions = Nothing- ,nixMonoidPath = Nothing- }- mappend l r = NixOptsMonoid- {nixMonoidDefaultEnable = nixMonoidDefaultEnable l || nixMonoidDefaultEnable r- ,nixMonoidEnable = nixMonoidEnable l <|> nixMonoidEnable r- ,nixMonoidPureShell = nixMonoidPureShell l <|> nixMonoidPureShell r- ,nixMonoidPackages = nixMonoidPackages l <|> nixMonoidPackages r- ,nixMonoidInitFile = nixMonoidInitFile l <|> nixMonoidInitFile r- ,nixMonoidShellOptions = nixMonoidShellOptions l <|> nixMonoidShellOptions r- ,nixMonoidPath = nixMonoidPath l <|> nixMonoidPath r- }+ mempty = memptydefault+ mappend = mappenddefault -- | Nix enable argument name. nixEnableArgName :: Text
src/Stack/Types/Package.hs view
@@ -37,6 +37,7 @@ import GHC.Generics (Generic) import Path as FL import Prelude+import Stack.Types.BuildPlan (GitSHA1) import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName@@ -87,6 +88,7 @@ ,packageDeps :: !(Map PackageName VersionRange) -- ^ Packages that the package depends on. ,packageTools :: ![Dependency] -- ^ A build tool name. ,packageAllDeps :: !(Set PackageName) -- ^ Original dependencies (not sieved).+ ,packageGhcOptions :: ![Text] -- ^ Ghc options used on package. ,packageFlags :: !(Map FlagName Bool) -- ^ Flags used on package. ,packageDefaultFlags :: !(Map FlagName Bool) -- ^ Defaults for unspecified flags. ,packageHasLibrary :: !Bool -- ^ does the package have a buildable library stanza?@@ -200,7 +202,8 @@ data PackageConfig = PackageConfig {packageConfigEnableTests :: !Bool -- ^ Are tests enabled? ,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled?- ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Package config flags.+ ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Configured flags.+ ,packageConfigGhcOptions :: ![Text] -- ^ Configured ghc options. ,packageConfigCompilerVersion :: !CompilerVersion -- ^ GHC version ,packageConfigPlatform :: !Platform -- ^ host platform }@@ -219,17 +222,17 @@ -- | Where the package's source is located: local directory or package index data PackageSource = PSLocal LocalPackage- | PSUpstream Version InstallLocation (Map FlagName Bool)+ | PSUpstream Version InstallLocation (Map FlagName Bool) [Text] (Maybe GitSHA1) -- ^ Upstream packages could be installed in either local or snapshot -- databases; this is what 'InstallLocation' specifies. deriving Show instance PackageInstallInfo PackageSource where piiVersion (PSLocal lp) = packageVersion $ lpPackage lp- piiVersion (PSUpstream v _ _) = v+ piiVersion (PSUpstream v _ _ _ _) = v piiLocation (PSLocal _) = Local- piiLocation (PSUpstream _ loc _) = loc+ piiLocation (PSUpstream _ loc _ _ _) = loc -- | Datatype which tells how which version of a package to install and where -- to install it into
src/Stack/Types/Sig.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}@@ -16,9 +15,8 @@ module Stack.Types.Sig (Signature(..), Fingerprint, mkFingerprint, SigException(..)) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>))-#endif+import Prelude ()+import Prelude.Compat import Control.Exception (Exception) import Data.Aeson (Value(..), ToJSON(..), FromJSON(..))
src/Stack/Types/StackT.hs view
@@ -87,13 +87,13 @@ monadLoggerLog = stickyLoggerFunc -- | Run a Stack action, using global options.-runStackTGlobal :: (MonadIO m,MonadBaseControl IO m)+runStackTGlobal :: (MonadIO m) => Manager -> config -> GlobalOpts -> StackT config m a -> m a runStackTGlobal manager config GlobalOpts{..} = runStackT manager globalLogLevel config globalTerminal (isJust globalReExecVersion) -- | Run a Stack action.-runStackT :: (MonadIO m,MonadBaseControl IO m)+runStackT :: (MonadIO m) => Manager -> LogLevel -> config -> Bool -> Bool -> StackT config m a -> m a runStackT manager logLevel config terminal reExec m = do canUseUnicode <- liftIO getCanUseUnicode@@ -216,8 +216,8 @@ -------------------------------------------------------------------------------- -- Logging functionality-stickyLoggerFunc :: (HasSticky r, HasLogLevel r, HasSupportsUnicode r, ToLogStr msg, MonadReader r (t m), MonadTrans t, MonadIO (t m))- => Loc -> LogSource -> LogLevel -> msg -> t m ()+stickyLoggerFunc :: (HasSticky r, HasLogLevel r, HasSupportsUnicode r, ToLogStr msg, MonadReader r m, MonadIO m)+ => Loc -> LogSource -> LogLevel -> msg -> m () stickyLoggerFunc loc src level msg = do Sticky mref <- asks getSticky case mref of
src/Stack/Types/Urls.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} module Stack.Types.Urls where @@ -6,6 +8,8 @@ import Data.Aeson.Extended import Data.Text (Text) import Data.Monoid+import GHC.Generics (Generic)+import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Prelude data Urls = Urls@@ -24,11 +28,11 @@ <*> o ..: "nightly-build-plans" data UrlsMonoid = UrlsMonoid- { urlsMonoidLatestSnapshot :: !(Maybe Text)- , urlsMonoidLtsBuildPlans :: !(Maybe Text)- , urlsMonoidNightlyBuildPlans :: !(Maybe Text)+ { urlsMonoidLatestSnapshot :: !(First Text)+ , urlsMonoidLtsBuildPlans :: !(First Text)+ , urlsMonoidNightlyBuildPlans :: !(First Text) }- deriving Show+ deriving (Show, Generic) instance FromJSON (WithJSONWarnings UrlsMonoid) where parseJSON = withObjectWarnings "UrlsMonoid" $ \o -> do@@ -38,9 +42,5 @@ <*> o ..: "nightly-build-plans" instance Monoid UrlsMonoid where- mempty = UrlsMonoid Nothing Nothing Nothing- mappend l r = UrlsMonoid- { urlsMonoidLatestSnapshot = urlsMonoidLatestSnapshot l <|> urlsMonoidLatestSnapshot r- , urlsMonoidLtsBuildPlans = urlsMonoidLtsBuildPlans l <|> urlsMonoidLtsBuildPlans r- , urlsMonoidNightlyBuildPlans = urlsMonoidNightlyBuildPlans l <|> urlsMonoidNightlyBuildPlans r- }+ mempty = memptydefault+ mappend = mappenddefault
src/Stack/Types/Version.hs view
@@ -11,6 +11,7 @@ module Stack.Types.Version (Version ,Cabal.VersionRange -- TODO in the future should have a newtype wrapper+ ,IntersectingVersionRange(..) ,VersionCheck(..) ,versionParser ,parseVersion@@ -41,6 +42,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (listToMaybe)+import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text)@@ -104,6 +106,15 @@ go (k, v) = do k' <- either (fail . show) return $ parseVersionFromString k return (k', v)++newtype IntersectingVersionRange =+ IntersectingVersionRange { getIntersectingVersionRange :: Cabal.VersionRange }+ deriving Show++instance Monoid IntersectingVersionRange where+ mempty = IntersectingVersionRange Cabal.anyVersion+ mappend (IntersectingVersionRange l) (IntersectingVersionRange r) =+ IntersectingVersionRange (l `Cabal.intersectVersionRanges` r) -- | Attoparsec parser for a package version. versionParser :: Parser Version
src/Stack/Upgrade.hs view
@@ -8,14 +8,12 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger-import Control.Monad.Reader (MonadReader, asks)+import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Control import Data.Foldable (forM_) import qualified Data.Map as Map import Data.Maybe (isNothing)-import Data.Monoid ((<>))-import qualified Data.Monoid-import qualified Data.Set as Set+import Data.Monoid.Extra import qualified Data.Text as T import Lens.Micro (set) import Network.HTTP.Client.Conduit (HasHttpManager)@@ -34,11 +32,12 @@ import System.Process.Run upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)- => Maybe String -- ^ git repository to use+ => ConfigMonoid+ -> Maybe String -- ^ git repository to use -> Maybe AbstractResolver -> Maybe String -- ^ git hash at time of building, if known -> m ()-upgrade gitRepo mresolver builtHash =+upgrade gConfigMonoid gitRepo mresolver builtHash = withSystemTempDir "stack-upgrade" $ \tmp -> do menv <- getMinimalEnvOverride mdir <- case gitRepo of@@ -83,24 +82,22 @@ return Nothing Just version -> do let ident = PackageIdentifier $(mkPackageName "stack") version- paths <- unpackPackageIdents menv tmp Nothing $ Set.singleton ident+ paths <- unpackPackageIdents menv tmp Nothing+ -- accept latest cabal revision by not supplying a Git SHA+ $ Map.singleton ident Nothing case Map.lookup ident paths of Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found" Just path -> return $ Just path - config <- asks getConfig forM_ mdir $ \dir -> do- bconfig <- runInnerStackLoggingT $ do- lc <- loadConfig- (configConfigMonoid config <> Data.Monoid.mempty- { configMonoidInstallGHC = Just True- })- (Just $ dir </> $(mkRelFile "stack.yaml"))- mresolver- lcLoadBuildConfig lc Nothing+ lc <- loadConfig+ gConfigMonoid+ mresolver+ (Just $ dir </> $(mkRelFile "stack.yaml"))+ bconfig <- lcLoadBuildConfig lc Nothing envConfig1 <- runInnerStackT bconfig $ setupEnv $ Just $ "Try rerunning with --install-ghc to install the correct GHC into " <>- T.pack (toFilePath (configLocalPrograms config))+ T.pack (toFilePath (configLocalPrograms (getConfig bconfig))) runInnerStackT (set (envConfigBuildOpts.buildOptsInstallExes) True envConfig1) $ build (const $ return ()) Nothing defaultBuildOptsCLI { boptsCLITargets = ["stack"]
src/main/Main.hs view
@@ -628,7 +628,7 @@ , "programs" , T.pack . toFilePathNoTrailingSep . configLocalPrograms . bcConfig . piBuildConfig ) , ( "Compiler binary (e.g. ghc)"- , "compiler"+ , "compiler-exe" , T.pack . toFilePath . piCompiler ) , ( "Directory containing the compiler binary (e.g. ghc)" , "compiler-bin"@@ -751,7 +751,7 @@ , configCompilerCheck (lcConfig lc) , Just $ bcStackYaml bc )- miniConfig <- loadMiniConfig (lcConfig lc)+ miniConfig <- loadMiniConfig manager (lcConfig lc) mpaths <- runStackTGlobal manager miniConfig go $ ensureCompiler SetupOpts { soptsInstallIfMissing = True@@ -827,31 +827,48 @@ act $ Just lk)) else act Nothing -withConfigAndLock :: GlobalOpts- -> StackT Config IO ()- -> IO ()+withConfigAndLock+ :: GlobalOpts+ -> StackT Config IO ()+ -> IO () withConfigAndLock go@GlobalOpts{..} inner = do (manager, lc) <- loadConfigWithOpts go withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk ->- runStackTGlobal manager (lcConfig lc) go $- Docker.reexecWithOptionalContainer (lcProjectRoot lc)- Nothing- (runStackTGlobal manager (lcConfig lc) go inner)- Nothing- (Just $ munlockFile lk)+ runStackTGlobal manager (lcConfig lc) go $+ Docker.reexecWithOptionalContainer+ (lcProjectRoot lc)+ Nothing+ (runStackTGlobal manager (lcConfig lc) go inner)+ Nothing+ (Just $ munlockFile lk) +-- | Loads global config, ignoring any configuration which would be+-- loaded due to $PWD.+withGlobalConfigAndLock+ :: GlobalOpts+ -> StackT Config IO ()+ -> IO ()+withGlobalConfigAndLock go@GlobalOpts{..} inner = do+ manager <- newTLSManager+ lc <- runStackLoggingTGlobal manager go $+ loadConfigMaybeProject globalConfigMonoid Nothing Nothing+ withUserFileLock go (configStackRoot $ lcConfig lc) $ \_lk ->+ runStackTGlobal manager (lcConfig lc) go inner+ -- For now the non-locking version just unlocks immediately. -- That is, there's still a serialization point.-withBuildConfig :: GlobalOpts- -> StackT EnvConfig IO ()- -> IO ()+withBuildConfig+ :: GlobalOpts+ -> StackT EnvConfig IO ()+ -> IO () withBuildConfig go inner = withBuildConfigAndLock go (\lk -> do munlockFile lk inner) -withBuildConfigAndLock :: GlobalOpts- -> (Maybe FileLock -> StackT EnvConfig IO ())- -> IO ()+withBuildConfigAndLock+ :: GlobalOpts+ -> (Maybe FileLock -> StackT EnvConfig IO ())+ -> IO () withBuildConfigAndLock go inner = withBuildConfigExt go Nothing inner Nothing @@ -956,8 +973,9 @@ getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices upgradeCmd :: (Bool, String) -> GlobalOpts -> IO ()-upgradeCmd (fromGit, repo) go = withConfigAndLock go $- upgrade (if fromGit then Just repo else Nothing)+upgradeCmd (fromGit, repo) go = withGlobalConfigAndLock go $ do+ upgrade (globalConfigMonoid go)+ (if fromGit then Just repo else Nothing) (globalResolver go) #ifdef USE_GIT_INFO (find (/= "UNKNOWN") [$gitHash])@@ -979,7 +997,7 @@ unless (null invalid) $ error $ "stack upload expects a list sdist tarballs or cabal directories. Can't find " ++ show invalid- let getUploader :: (HasStackRoot config, HasPlatform config, HasConfig config) => StackT config IO Upload.Uploader+ let getUploader :: (HasConfig config) => StackT config IO Upload.Uploader getUploader = do config <- asks getConfig manager <- asks envManager@@ -1202,7 +1220,7 @@ manager <- newTLSManager mstackYaml <- forM globalStackYaml resolveFile' lc <- runStackLoggingTGlobal manager go $ do- lc <- loadConfig globalConfigMonoid mstackYaml globalResolver+ 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.@@ -1214,27 +1232,27 @@ withMiniConfigAndLock :: GlobalOpts- -> StackT MiniConfig (StackT Config IO) ()+ -> StackT MiniConfig IO () -> IO ()-withMiniConfigAndLock go inner =- withConfigAndLock go $ do- config <- asks getConfig- miniConfig <- loadMiniConfig config- manager <- asks getHttpManager- runStackTGlobal manager miniConfig go inner+withMiniConfigAndLock go@GlobalOpts{..} inner = do+ manager <- newTLSManager+ miniConfig <- runStackLoggingTGlobal manager go $ do+ lc <- loadConfigMaybeProject globalConfigMonoid globalResolver Nothing+ loadMiniConfig manager (lcConfig lc)+ runStackTGlobal manager miniConfig go inner -- | Project initialization initCmd :: InitOpts -> GlobalOpts -> IO () initCmd initOpts go = do pwd <- getCurrentDir- withMiniConfigAndLock go (initProject pwd initOpts (globalResolver go))+ withMiniConfigAndLock go (initProject IsInitCmd pwd initOpts (globalResolver go)) -- | Create a project directory structure and initialize the stack config. newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO () newCmd (newOpts,initOpts) go@GlobalOpts{..} = do withMiniConfigAndLock go $ do dir <- new newOpts (forceOverwrite initOpts)- initProject dir initOpts globalResolver+ initProject IsNewCmd dir initOpts globalResolver -- | List the available templates. templatesCmd :: () -> GlobalOpts -> IO ()
src/test/Network/HTTP/Download/VerifiedSpec.hs view
@@ -3,6 +3,8 @@ import Crypto.Hash import Control.Monad (unless)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Logger (LoggingT, runStdoutLoggingT) import Control.Monad.Trans.Reader import Control.Retry (limitRetries) import Data.Maybe@@ -65,8 +67,8 @@ { manager :: Manager } -runWith :: Manager -> ReaderT Manager m r -> m r-runWith = flip runReaderT+runWith :: MonadIO m => Manager -> ReaderT Manager (LoggingT m) r -> m r+runWith manager = runStdoutLoggingT . flip runReaderT manager setup :: IO T setup = do
src/test/Stack/BuildPlanSpec.hs view
@@ -83,10 +83,12 @@ mkMPI deps = MiniPackageInfo { mpiVersion = version , mpiFlags = Map.empty+ , mpiGhcOptions = [] , mpiPackageDeps = Set.fromList $ map pn $ words deps , mpiToolDeps = Set.empty , mpiExes = Set.empty , mpiHasLibrary = True+ , mpiGitSHA1 = Nothing } go x y = (pn x, mkMPI y) resourcet = go "resourcet" ""
stack.cabal view
@@ -1,5 +1,5 @@ name: stack-version: 1.1.0+version: 1.1.2 cabal-version: >=1.10 build-type: Simple license: BSD3@@ -65,6 +65,7 @@ Data.Binary.VersionTagged Data.IORef.RunOnce Data.Maybe.Extra+ Data.Monoid.Extra Distribution.Version.Extra Network.HTTP.Download Network.HTTP.Download.Verified@@ -144,12 +145,13 @@ System.Process.Read System.Process.Run build-depends:- Cabal >=1.18.1.5 && <1.23,+ Cabal >=1.18.1.5 && <1.25, aeson >=0.8.0.2 && <0.10 || ==0.11.*, ansi-terminal >=0.6.2.3 && <0.7, async >=2.0.2 && <2.2, attoparsec >=0.12.1.5 && <0.14, base >=4.7 && <5,+ base-compat >=0.6 && <0.10, base16-bytestring >=0.1.1.6 && <0.2, base64-bytestring >=1.0.0.1 && <1.1, binary ==0.7.*,@@ -164,16 +166,18 @@ cryptohash-conduit >=0.1.1 && <0.2, directory >=1.2.1.0 && <1.3, edit-distance ==0.2.*,- either >=4.4.1 && <4.5,+ either >=4.4.1.1 && <4.5, enclosed-exceptions >=1.0.1.1 && <1.1, errors >=2.1.2 && <2.2, exceptions >=0.8.0.2 && <0.9,- extra >=1.4.3 && <1.5,+ extra >=1.4.6 && <1.5, fast-logger >=2.3.1 && <2.5, filelock >=0.1.0.1 && <0.2, filepath >=1.3.0.2 && <1.5, fsnotify >=0.2.1 && <0.3,+ generic-deriving >=1.9.0 && <1.10, hashable >=1.2.3.2 && <1.3,+ hit >=0.6.3 && <0.7, hpc >=0.6.0.2 && <0.7, http-client >=0.4.17 && <0.5, http-client-tls >=0.2.2 && <0.3,@@ -183,6 +187,7 @@ microlens >=0.3.0.0 && <0.5, monad-control >=1.0.1.0 && <1.1, monad-logger >=0.3.13.1 && <0.4,+ monad-unlift >=0.1.2.0 && <0.2, mtl >=2.1.3.1 && <2.3, open-browser >=0.2.1 && <0.3, optparse-applicative >=0.11 && <0.13,@@ -193,11 +198,12 @@ persistent-template >=2.1.1 && <2.6, pretty >=1.1.1.1 && <1.2, process >=1.2.0.0 && <1.3,+ regex-applicative-text >=0.1.0.1 && <0.2, resourcet >=1.1.4.1 && <1.2, retry >=0.6 && <0.8, safe ==0.3.*, semigroups >=0.5 && <0.19,- split >=0.2.3 && <0.3,+ split >=0.2.3.1 && <0.3, stm >=2.4.4 && <2.5, streaming-commons >=0.1.10.0 && <0.2, tar >=0.4.1.0 && <0.6,@@ -206,6 +212,7 @@ text >=1.2.0.4 && <1.3, text-binary >=0.2.1 && <0.3, time >=1.4.2 && <1.6,+ tls >=1.3.8 && <1.4, transformers >=0.3.0.0 && <0.5, transformers-base >=0.4.4 && <0.5, unix-compat >=0.4.1.4 && <0.5,@@ -218,7 +225,7 @@ hastache >=0.6.1 && <0.7, project-template ==0.2.*, zip-archive >=0.2.3.7 && <0.3,- hpack >=0.10.0 && <0.14+ hpack >=0.14.0 && <0.15 default-language: Haskell2010 hs-source-dirs: src/ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates@@ -240,7 +247,7 @@ cpp-options: -DUSE_GIT_INFO main-is: Main.hs build-depends:- Cabal >=1.18.1.5 && <1.23,+ Cabal >=1.18.1.5 && <1.25, base >=4.7 && <5, bytestring >=0.10.4.0 && <0.11, containers >=0.5.5.1 && <0.6,@@ -256,7 +263,7 @@ optparse-applicative >=0.11.0.2 && <0.13, path >=0.5.7 && <0.6, path-io >=1.1.0 && <2.0.0,- stack >=1.1.0 && <1.2,+ stack >=1.1.2 && <1.2, text >=1.2.0.4 && <1.3, transformers >=0.4.2.0 && <0.5 default-language: Haskell2010@@ -269,24 +276,24 @@ type: exitcode-stdio-1.0 main-is: Test.hs build-depends:- Cabal >=1.18.1.5 && <1.23,+ Cabal >=1.18.1.5 && <1.25, QuickCheck >=2.8.1 && <2.9, attoparsec >=0.13.0.2 && <0.14, base >=4.7 && <5,- conduit >=1.2.6.4 && <1.3,+ conduit >=1.2.6.6 && <1.3, conduit-extra >=1.1.13.1 && <1.2, containers >=0.5.5.1 && <0.6, cryptohash >=0.11.6 && <0.12, directory >=1.2.2.0 && <1.3, exceptions >=0.8.2.1 && <0.9, hspec >=2.2.3 && <2.3,- http-conduit >=2.1.10 && <2.2,+ http-conduit >=2.1.10.1 && <2.2, monad-logger >=0.3.18 && <0.4, path >=0.5.7 && <0.6, path-io >=1.1.0 && <2.0.0,- resourcet >=1.1.7.3 && <1.2,+ resourcet >=1.1.7.4 && <1.2, retry >=0.6 && <0.8,- stack >=1.1.0 && <1.2,+ stack >=1.1.2 && <1.2, temporary >=1.2.0.4 && <1.3, text >=1.2.2.1 && <1.3, transformers >=0.4.2.0 && <0.5@@ -314,14 +321,14 @@ async >=2.1.0 && <2.2, base >=4.7 && <5, bytestring >=0.10.6.0 && <0.11,- conduit >=1.2.6.4 && <1.3,+ conduit >=1.2.6.6 && <1.3, conduit-extra >=1.1.13.1 && <1.2, containers >=0.5.5.1 && <0.6, directory >=1.2.2.0 && <1.3, filepath >=1.4.0.0 && <1.5, hspec >=2.2.3 && <2.3, process >=1.2.3.0 && <1.3,- resourcet >=1.1.7.3 && <1.2,+ resourcet >=1.1.7.4 && <1.2, temporary >=1.2.0.4 && <1.3, text >=1.2.2.1 && <1.3, transformers >=0.4.2.0 && <0.5,
stack.yaml view
@@ -1,4 +1,4 @@-resolver: lts-5.14+resolver: lts-5.17 # docker: # enable: true # repo: fpco/stack-full@@ -12,6 +12,7 @@ packages: - zlib extra-deps:-- hpack-0.13.0+- hpack-0.14.0 - path-io-1.1.0 - th-lift-instances-0.1.6+- aeson-0.11.2.0
test/integration/lib/StackTest.hs view
@@ -129,4 +129,4 @@ -- version is released, pass this argument to @stack@ when running in -- a global context. The LTS major version here should match that of -- the main @stack.yaml@.-defaultResolverArg = "--resolver=lts-4"+defaultResolverArg = "--resolver=lts-5"