diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -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: diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/doc/CONTRIBUTING.md b/doc/CONTRIBUTING.md --- a/doc/CONTRIBUTING.md +++ b/doc/CONTRIBUTING.md @@ -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: diff --git a/doc/ChangeLog.md b/doc/ChangeLog.md --- a/doc/ChangeLog.md +++ b/doc/ChangeLog.md @@ -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. diff --git a/doc/GUIDE.md b/doc/GUIDE.md --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -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 diff --git a/doc/MAINTAINER_GUIDE.md b/doc/MAINTAINER_GUIDE.md --- a/doc/MAINTAINER_GUIDE.md +++ b/doc/MAINTAINER_GUIDE.md @@ -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 ` * [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 diff --git a/doc/README.md b/doc/README.md --- a/doc/README.md +++ b/doc/README.md @@ -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) diff --git a/doc/docker_integration.md b/doc/docker_integration.md --- a/doc/docker_integration.md +++ b/doc/docker_integration.md @@ -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) diff --git a/doc/faq.md b/doc/faq.md --- a/doc/faq.md +++ b/doc/faq.md @@ -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 -```` +``` Or, if you want to install the binaries in a shared location: ``` $ stack install diff --git a/doc/install_and_upgrade.md b/doc/install_and_upgrade.md --- a/doc/install_and_upgrade.md +++ b/doc/install_and_upgrade.md @@ -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) diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -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] diff --git a/src/Data/Monoid/Extra.hs b/src/Data/Monoid/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Monoid/Extra.hs @@ -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 diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs --- a/src/Network/HTTP/Download.hs +++ b/src/Network/HTTP/Download.hs @@ -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 diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -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 diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs --- a/src/Options/Applicative/Builder/Extra.hs +++ b/src/Options/Applicative/Builder/Extra.hs @@ -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 diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -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 diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -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 diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -1,3 +1,4 @@ +{-# 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 diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -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 diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -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 diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -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 } diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -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 + } diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -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 diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs --- a/src/Stack/Config/Build.hs +++ b/src/Stack/Config/Build.hs @@ -3,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 } diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -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{..} diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -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 diff --git a/src/Stack/Config/Urls.hs b/src/Stack/Config/Urls.hs --- a/src/Stack/Config/Urls.hs +++ b/src/Stack/Config/Urls.hs @@ -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" diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -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 diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -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) diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -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 diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -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" diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -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 () diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs --- a/src/Stack/Exec.hs +++ b/src/Stack/Exec.hs @@ -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 diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -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) diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -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 diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -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) diff --git a/src/Stack/Ide.hs b/src/Stack/Ide.hs --- a/src/Stack/Ide.hs +++ b/src/Stack/Ide.hs @@ -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 () diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -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 diff --git a/src/Stack/New.hs b/src/Stack/New.hs --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -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) diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -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@. diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -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') diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -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 diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -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) diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -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 diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -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 diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -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) diff --git a/src/Stack/Sig/GPG.hs b/src/Stack/Sig/GPG.hs --- a/src/Stack/Sig/GPG.hs +++ b/src/Stack/Sig/GPG.hs @@ -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`)")) diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs --- a/src/Stack/Sig/Sign.hs +++ b/src/Stack/Sig/Sign.hs @@ -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 = diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -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) diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -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 diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -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 diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -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) diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -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 diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -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 diff --git a/src/Stack/Types/Image.hs b/src/Stack/Types/Image.hs --- a/src/Stack/Types/Image.hs +++ b/src/Stack/Types/Image.hs @@ -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 diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs --- a/src/Stack/Types/Internal.hs +++ b/src/Stack/Types/Internal.hs @@ -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 = diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -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 diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -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 diff --git a/src/Stack/Types/Sig.hs b/src/Stack/Types/Sig.hs --- a/src/Stack/Types/Sig.hs +++ b/src/Stack/Types/Sig.hs @@ -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(..)) diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs --- a/src/Stack/Types/StackT.hs +++ b/src/Stack/Types/StackT.hs @@ -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 diff --git a/src/Stack/Types/Urls.hs b/src/Stack/Types/Urls.hs --- a/src/Stack/Types/Urls.hs +++ b/src/Stack/Types/Urls.hs @@ -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 diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -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 diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -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"] diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -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 () diff --git a/src/test/Network/HTTP/Download/VerifiedSpec.hs b/src/test/Network/HTTP/Download/VerifiedSpec.hs --- a/src/test/Network/HTTP/Download/VerifiedSpec.hs +++ b/src/test/Network/HTTP/Download/VerifiedSpec.hs @@ -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 diff --git a/src/test/Stack/BuildPlanSpec.hs b/src/test/Stack/BuildPlanSpec.hs --- a/src/test/Stack/BuildPlanSpec.hs +++ b/src/test/Stack/BuildPlanSpec.hs @@ -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" "" diff --git a/stack.cabal b/stack.cabal --- a/stack.cabal +++ b/stack.cabal @@ -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, diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs --- a/test/integration/lib/StackTest.hs +++ b/test/integration/lib/StackTest.hs @@ -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"