diff --git a/ChangeLog.md b/ChangeLog.md index 8cabeb2b0d..a8c89f7d55 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,7 +2,7 @@ Major changes: -* GHCJS can now be used with stackage snapshots. +* GHCJS can now be used with stackage snapshots via the new `compiler` field. * Windows installers are now available: [download them here](https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md#windows) [#613](https://github.com/commercialhaskell/stack/issues/613) @@ -13,11 +13,19 @@ Other enhancements: * Added a `stack config set resolver RESOLVER` command. Part of work on [#115](https://github.com/commercialhaskell/stack/issues/115) * `stack setup` can now install GHCJS on windows. See [#1145](https://github.com/commercialhaskell/stack/issues/1145) and [#749](https://github.com/commercialhaskell/stack/issues/749) * `stack hpc report` command added, which generates reports for HPC tix files +* `stack ghci` now accepts all the flags accepted by `stack build`. See [#1186](https://github.com/commercialhaskell/stack/issues/1186) +* `stack ghci` builds the project before launching GHCi. If the build fails, optimistically launch GHCi anyway. Use `stack ghci --no-build` option to disable [#1065](https://github.com/commercialhaskell/stack/issues/1065) +* `stack ghci` now detects and warns about various circumstances where it is liable to fail. See [#1270](https://github.com/commercialhaskell/stack/issues/1270) +* Added `require-docker-version` configuration option +* Packages will now usually be built along with their tests and benchmarks. See [#1166](https://github.com/commercialhaskell/stack/issues/1166) Bug fixes: -* Haddocks not copied for dependencies [#1105](https://github.com/commercialhaskell/stack/issues/1105) +* Fix: Haddocks not copied for dependencies [#1105](https://github.com/commercialhaskell/stack/issues/1105) +* Fix: Global options did not work consistently after subcommand [#519](https://github.com/commercialhaskell/stack/issues/519) +* Fix: 'stack ghci' doesn't notice that a module got deleted [#1180](https://github.com/commercialhaskell/stack/issues/1180) * Rebuild when cabal file is changed +* Fix: Paths in GHC warnings not canonicalized, nor those for packages in subdirectories or outside the project root [#1259](https://github.com/commercialhaskell/stack/issues/1259) ## v0.1.6.0 diff --git a/LICENSE b/LICENSE index ec95f09b73..8d29dc30d2 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, stack +Copyright (c) 2015, Stack contributors All rights reserved. Redistribution and use in source and binary forms, with or without @@ -15,7 +15,7 @@ modification, are permitted provided that the following conditions are met: THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND diff --git a/README.md b/README.md index 45935ad999..a6e94ef261 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ ## The Haskell Tool Stack [![Build Status](https://travis-ci.org/commercialhaskell/stack.svg?branch=master)](https://travis-ci.org/commercialhaskell/stack) -[![Windows build status](https://ci.appveyor.com/api/projects/status/github/commercialhaskell/stack)](https://ci.appveyor.com/project/snoyberg/stack) +[![Windows build status](https://ci.appveyor.com/api/projects/status/c1c7uvmw6x1dupcl?svg=true)](https://ci.appveyor.com/project/snoyberg/stack) [![Release](https://img.shields.io/github/release/commercialhaskell/stack.svg)](https://github.com/commercialhaskell/stack/releases) `stack` is a cross-platform program for developing Haskell diff --git a/appveyor.yml b/appveyor.yml index aabcef8e85..d792697c5a 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -1,5 +1,6 @@ -cache: -- "c:\\sr" # stack root, short paths == less problems +# Disabled cache in hope of improving reliability of AppVeyor builds +#cache: +#- "c:\\sr" # stack root, short paths == less problems build: off diff --git a/doc/GUIDE.md b/doc/GUIDE.md index 7f7729db19..63164aad22 100644 --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -939,7 +939,7 @@ understand why rebuilding may occur at different points. Let's look at a subset of the `stack --help` output: ``` -build Build the project(s) in this directory/configuration +build Build the package(s) in this directory/configuration install Shortcut for 'build --copy-bins' test Shortcut for 'build --test' bench Shortcut for 'build --bench' diff --git a/doc/dependency_visualization.md b/doc/dependency_visualization.md index 4ed0875a45..110dd6115e 100644 --- a/doc/dependency_visualization.md +++ b/doc/dependency_visualization.md @@ -1,4 +1,4 @@ -You can use stack to visualize the dependencies between your projects and optionally also external dependencies. +You can use stack to visualize the dependencies between your packages and optionally also external dependencies. As an example, let's look at `wreq`: @@ -39,5 +39,3 @@ and pass in options to `dot` or use another graph layout engine like `twopi`: $ stack dot --external --prune base,lens,wreq-examples,http-client,aeson,tls,http-client-tls,exceptions | twopi -Groot=wreq -Goverlap=false -Tpng -o wreq_pruned.png ``` [![wreq_pruned](https://cloud.githubusercontent.com/assets/591567/8495538/9fae1184-216e-11e5-9931-99e6147f8aed.png)](https://cloud.githubusercontent.com/assets/591567/8495538/9fae1184-216e-11e5-9931-99e6147f8aed.png) - - diff --git a/doc/docker_integration.md b/doc/docker_integration.md index 341e588eb6..6ceb036842 100644 --- a/doc/docker_integration.md +++ b/doc/docker_integration.md @@ -203,6 +203,10 @@ otherwise noted. # When the Docker Engine is remote (accessed by tcp), defaults to false. set-user: true + # Require the version of the Docker client to be within the specified + # Cabal-style version range (e.g., ">= 1.6.0 && < 1.9.0") + require-docker-version: "any" + Image Repositories ------------------------------------------------------------------------------- diff --git a/doc/faq.md b/doc/faq.md index 5d0630cb86..4ec1dbebf4 100644 --- a/doc/faq.md +++ b/doc/faq.md @@ -275,3 +275,7 @@ collect2: error: ld returned 1 exit status /home/philip/.stack/programs/x86_64-linux/ghc-7.10.1/bin/runghc-7.10.1 -package=Cabal-1.22.2.0 -clear-package-db -global-package-db /home/philip/tmp/Setup.hs --builddir=dist-stack/x86_64-linux/Cabal-1.22.2.0/ build Process exited with code: ExitFailure 1 ``` + +#### Where does the output from `--ghc-options=-ddump-splices` (and other `-ddump*` options) go? + +These are written to `*.dump-*` files inside the package's `.stack-work` directory. diff --git a/doc/nonstandard_project_init.md b/doc/nonstandard_project_init.md index 21a25939bc..aa77301917 100644 --- a/doc/nonstandard_project_init.md +++ b/doc/nonstandard_project_init.md @@ -1,15 +1,15 @@ # Introduction -The purpose of this page is to collect information about issues that arise when users either have an existing cabal project or another nonstandard setup such as a private hackage database. +The purpose of this page is to collect information about issues that arise when users either have an existing cabal project or another nonstandard setup such as a private hackage database. # Using a Cabal File -New users may be confused by the fact that you must add dependencies to the projects cabal file, even in the case when you have already listed the package in the `stack.yaml`. In most cases, dependencies for your project that are in the Stackage snapshot need *only* be added to the cabal file. stack makes heavy use of Cabal the library under the hood. In general, your stack packages should also end up being valid cabal-install packages. +New users may be confused by the fact that you must add dependencies to the package's cabal file, even in the case when you have already listed the package in the `stack.yaml`. In most cases, dependencies for your package that are in the Stackage snapshot need *only* be added to the cabal file. stack makes heavy use of Cabal the library under the hood. In general, your stack packages should also end up being valid cabal-install packages. ## Issues Referenced - https://github.com/commercialhaskell/stack/issues/105 # Passing Flags to Cabal -Any build command, `bench`, `install`, `haddock`, `test`, etc. takes a `--flag` option which passes flags to cabal. Another way to do this is using the flags field in a `stack.yaml`, with the option to specify flags on a per project basis. +Any build command, `bench`, `install`, `haddock`, `test`, etc. takes a `--flag` option which passes flags to cabal. Another way to do this is using the flags field in a `stack.yaml`, with the option to specify flags on a per package basis. As an example, in a `stack.yaml` for multi-package project with packages `foo`, `bar`, `baz`: @@ -25,7 +25,7 @@ flags: It is also possible to pass the same flag to multiple packages, i.e. `stack build --flag *:necessary` -Currently one needs to list all of your modules that interpret flags in the `other-modules` section of a cabal file. `cabal-install` has a different behavior currently and doesn't require that the modules be listed. This may change in a future release. +Currently one needs to list all of your modules that interpret flags in the `other-modules` section of a cabal file. `cabal-install` has a different behavior currently and doesn't require that the modules be listed. This may change in a future release. ## Issues Referenced @@ -87,7 +87,7 @@ Currently WIP? - https://github.com/commercialhaskell/stack/issues/137 # Intra-package Targets -stack supports intra-package targets, similar to `cabal build COMPONENTS` for situations when you don't want to build every target inside your package. +stack supports intra-package targets, similar to `cabal build COMPONENTS` for situations when you don't want to build every target inside your package. Example: ``` diff --git a/doc/shell_autocompletion.md b/doc/shell_autocompletion.md index 8afe0b5d84..bdd127e531 100644 --- a/doc/shell_autocompletion.md +++ b/doc/shell_autocompletion.md @@ -4,7 +4,7 @@ Note: if you installed a package for you Linux distribution, the bash completion file was automatically installed (you may need the `bash-completion` package to have it take effect). -The following adds support for shell tab completion for standard Stack arguments, although completion for filenames and executables etc. within stack is still lacking (see [issue 82](https://github.com/commercialhaskell/stack/issues/832)). +The following adds support for shell tab completion for standard Stack arguments, although completion for filenames and executables etc. within stack is still lacking (see [issue 823](https://github.com/commercialhaskell/stack/issues/832)). ### for bash users diff --git a/doc/stack_and_ghcjs.md b/doc/stack_and_ghcjs.md new file mode 100644 index 0000000000..053f800299 --- /dev/null +++ b/doc/stack_and_ghcjs.md @@ -0,0 +1,75 @@ +# Stack & GHCJS + +To set up and use GHCJS with stack, you should place GHCJS `resolver` in your project's `stack.yaml` (see instructions for [old base](#ghcjs-old-base) and [`master` - a.k.a. improved base](#ghcjs-master-aka-improved-base)). Once this has been done, Stack will use GHCJS for most commands, with the exception of `ghc`, `runghc` and `ide`. (Support for `ghc` and `runghc` will likely be added before the next release - see [#1054](https://github.com/commercialhaskell/stack/issues/1054)). + +After creating a `stack.yaml`, which specifies that ghcjs is to be used (see below), you can have Stack automatically set up and boot GHCJS. Stack must be newer than `0.1.6`: + +``` +$ stack setup +``` + +(this will take a long time) + +## Using a stackage snapshot + +The configurations below use a compiler resolver, which means that you can't use packages from a stackage snapshot. The latest development version (which will probably be released as `0.1.7`) also supports using GHCJS with a stackage snapshot, via a `compiler` field. To use the latest development version, do the following: + +``` +$ stack upgrade --git +``` + +For example, the old-base configuration looks like this: + +```yaml +resolver: lts-3.10 +compiler: ghcjs-0.1.0.20150924_ghc-7.10.2 +compiler-check: match-exact +``` + +You can also build existing stack projects which target GHC and instead build them with GHCJS. To do this, invoke stack like this: `stack build --compiler ghcjs-0.1.0.20150924_ghc-7.10.2` + +## Example Configurations + +### GHCJS (old base) + +You can use this resolver for GHCJS (old base) in your `stack.yaml`: + +```yaml +resolver: ghcjs-0.1.0.20150924_ghc-7.10.2 +compiler-check: match-exact +``` + +### GHCJS `master` (a.k.a. improved base) + +To use the master branch, a.k.a improved base, add the following to your `stack.yaml`: + +```yaml +resolver: ghcjs-0.2.0.20151001_ghc-7.10.2 +compiler-check: match-exact +setup-info: + ghcjs: + source: + ghcjs-0.2.0.20151001_ghc-7.10.2: + url: "https://github.com/fizruk/ghcjs/releases/download/v0.2.0.20151001/ghcjs-0.2.0.20151001.tar.gz" +``` + +or for the 2015-10-29 master branch +```yaml +resolver: ghcjs-0.2.0.20151029_ghc-7.10.2 +compiler-check: match-exact +setup-info: + ghcjs: + source: + ghcjs-0.2.0.20151029_ghc-7.10.2: + url: "https://github.com/nrolland/ghcjs/releases/download/v0.2.0.20151029/ghcjs-0.2.0.20151029.tar.gz" +``` + +### Custom installed GHCJS (development branch) + +In order to use a GHCJS installed on your path, just add the following to your `stack.yaml`: + +```yaml +resolver: ghcjs-0.2.0_ghc-7.10.2 +``` + +(Or, `ghcjs-0.1.0_ghc-7.10.2` if you are working with an older version) diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index de1b059a4d..0769e7dec4 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -118,7 +118,7 @@ Non-project config options may go in the global config (`/etc/stack/config.yaml` ### docker -See [Docker configuration](Docker#configuration). +See [Docker configuration](https://github.com/commercialhaskell/stack/blob/release/doc/docker_integration.md). ### connection-count @@ -222,6 +222,23 @@ Specifies how the compiler version in the resolver is matched against concrete v * `match-exact`: the entire version number must match precisely * `newer-minor`: the third component can be increased, e.g. if your resolver is `ghc-7.10.1`, then 7.10.2 will also be allowed. This was the default up through stack 0.1.3 +### compiler + +(Since 0.1.7) + +Overrides the compiler version in the resolver. Note that the `compiler-check` +flag also applies to the version numbers. This uses the same syntax as compiler +resolvers like `ghc-7.10.2` or `ghcjs-0.1.0.20150924_ghc-7.10.2` (version used +for the 'old-base' version of GHCJS). While it's useful to override the +compiler for a variety of reasons, the main usecase is to use GHCJS with a +stackage snapshot, like this: + +```yaml +resolver: lts-3.10 +compiler: ghcjs-0.1.0.20150924_ghc-7.10.2 +compiler-check: match-exact +``` + ### ghc-options (Since 0.1.4) @@ -306,15 +323,14 @@ modify-code-page: false (Since 0.1.6) -Decide whether a custom `Setup.hs` script should be run with an explicit list -of dependencies based on the dependencies of the package itself, or simply -provided the global package database. This option is most often needed when -overriding packages in the global database, see [issue #1110](https://github.com/commercialhaskell/stack/issues/1110). - -Setting the list explicitly can help when a Setup.hs depends on packages in the -local package database. For more information on that case, see [issue #897](https://github.com/commercialhaskell/stack/issues/897). +Decide whether a custom `Setup.hs` script should be run with an explicit list of +dependencies, based on the dependencies of the package itself. It associates the +name of a local package with a boolean. When it's `true`, the `Setup.hs` script +is built with an explicit list of packages. When it's `false` (default), the +`Setup.hs` script is built without access to the local DB, but can access any +package in the snapshot / global DB. -Note that in the future, this should all disappear once Cabal provides full +Note that in the future, this will be unnecessary, once Cabal provides full support for explicit Setup.hs dependencies. ```yaml diff --git a/etc/scripts/release.hs b/etc/scripts/release.hs index 943675eb86..f65e186590 100644 --- a/etc/scripts/release.hs +++ b/etc/scripts/release.hs @@ -19,7 +19,6 @@ import System.Environment import System.Directory import System.IO.Error import System.Process -import System.Exit import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Zip as Zip @@ -62,7 +61,6 @@ main = gProjectRoot = "" -- Set to real value velow. global0 = foldl (flip id) Global{..} flags -- Need to get paths after options since the '--arch' argument can effect them. - localInstallRoot' <- getStackPath global0 "local-install-root" projectRoot' <- getStackPath global0 "project-root" let global = global0 { gProjectRoot = projectRoot' } diff --git a/src/Control/Concurrent/Execute.hs b/src/Control/Concurrent/Execute.hs index 8ce0bb26c8..224437ec2d 100644 --- a/src/Control/Concurrent/Execute.hs +++ b/src/Control/Concurrent/Execute.hs @@ -24,6 +24,7 @@ import Stack.Types data ActionType = ATBuild + | ATBuildFinal | ATFinal deriving (Show, Eq, Ord) data ActionId = ActionId !PackageIdentifier !ActionType diff --git a/src/Data/Attoparsec/Args.hs b/src/Data/Attoparsec/Args.hs index 090234e5b6..cc81e789a9 100644 --- a/src/Data/Attoparsec/Args.hs +++ b/src/Data/Attoparsec/Args.hs @@ -31,7 +31,7 @@ data EscapingMode -- | Parse arguments using 'argsParser'. parseArgs :: EscapingMode -> Text -> Either String [String] -parseArgs mode t = P.parseOnly (argsParser mode) t +parseArgs mode = P.parseOnly (argsParser mode) -- | A basic argument parser. It supports space-separated text, and -- string quotation with identity escaping: \x -> x. diff --git a/src/Data/Binary/VersionTagged.hs b/src/Data/Binary/VersionTagged.hs index c1d5211dc3..8e5e123a1d 100644 --- a/src/Data/Binary/VersionTagged.hs +++ b/src/Data/Binary/VersionTagged.hs @@ -25,53 +25,55 @@ import Data.Binary (Binary (..)) import Data.Binary.Get (ByteOffset) import Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion) import qualified Data.Binary.Tagged as BinaryTagged +import Data.Monoid ((<>)) import Data.Typeable (Typeable) import Control.Exception.Enclosed (tryAnyDeep) -import System.FilePath (takeDirectory) -import System.Directory (createDirectoryIfMissing) +import Path +import Path.IO (createTree) import qualified Data.Text as T type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a) -- | Write to the given file, with a binary-tagged tag. taggedEncodeFile :: (BinarySchema a, MonadIO m) - => FilePath + => Path Abs File -> a -> m () taggedEncodeFile fp x = liftIO $ do - createDirectoryIfMissing True $ takeDirectory fp - BinaryTagged.taggedEncodeFile fp x + createTree (parent fp) + BinaryTagged.taggedEncodeFile (toFilePath fp) x -- | Read from the given file. If the read fails, run the given action and -- write that back to the file. Always starts the file off with the version -- tag. taggedDecodeOrLoad :: (BinarySchema a, MonadIO m, MonadLogger m) - => FilePath + => Path Abs File -> m a -> m a taggedDecodeOrLoad fp mx = do - $logDebug $ T.pack $ "Trying to decode " ++ fp + let fpt = T.pack (toFilePath fp) + $logDebug $ "Trying to decode " <> fpt eres <- decodeFileOrFailDeep fp case eres of Left _ -> do - $logDebug $ T.pack $ "Failure decoding " ++ fp + $logDebug $ "Failure decoding " <> fpt x <- mx taggedEncodeFile fp x return x Right x -> do - $logDebug $ T.pack $ "Success decoding " ++ fp + $logDebug $ "Success decoding " <> fpt return x -- | Ensure that there are no lurking exceptions deep inside the parsed -- value... because that happens unfortunately. See -- https://github.com/commercialhaskell/stack/issues/554 decodeFileOrFailDeep :: (BinarySchema a, MonadIO m, MonadThrow n) - => FilePath + => Path loc File -> m (n a) decodeFileOrFailDeep fp = liftIO $ fmap (either throwM return) $ tryAnyDeep $ do - eres <- BinaryTagged.taggedDecodeFileOrFail fp + eres <- BinaryTagged.taggedDecodeFileOrFail (toFilePath fp) case eres of - Left (offset, str) -> throwM $ DecodeFileFailure fp offset str + Left (offset, str) -> throwM $ DecodeFileFailure (toFilePath fp) offset str Right x -> return x data DecodeFileFailure = DecodeFileFailure FilePath ByteOffset String diff --git a/src/Data/Maybe/Extra.hs b/src/Data/Maybe/Extra.hs index 5badc52335..2c83ff602e 100644 --- a/src/Data/Maybe/Extra.hs +++ b/src/Data/Maybe/Extra.hs @@ -2,9 +2,24 @@ module Data.Maybe.Extra where +import Control.Applicative import Control.Monad +import Data.Traversable hiding (mapM) import Data.Maybe +import Prelude -- Silence redundant import warnings + +-- | Applicative 'mapMaybe'. +mapMaybeA :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b] +mapMaybeA f = fmap catMaybes . traverse f + +-- | @'forMaybeA' '==' 'flip' 'mapMaybeA'@ +forMaybeA :: Applicative f => [a] -> (a -> f (Maybe b)) -> f [b] +forMaybeA = flip mapMaybeA -- | Monadic 'mapMaybe'. -mapMaybeM :: Monad f => (a -> f (Maybe b)) -> [a] -> f [b] +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM f = liftM catMaybes . mapM f + +-- | @'forMaybeM' '==' 'flip' 'mapMaybeM'@ +forMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b] +forMaybeM = flip mapMaybeM diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs index 021720747b..15fcbda448 100644 --- a/src/Network/HTTP/Download.hs +++ b/src/Network/HTTP/Download.hs @@ -24,6 +24,7 @@ module Network.HTTP.Download import Control.Exception (Exception) import Control.Exception.Enclosed (handleIO) +import Control.Monad (void) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader, ReaderT, ask, @@ -52,8 +53,8 @@ import System.Directory (createDirectoryIfMissing, removeFile, renameFile) import System.FilePath (takeDirectory, (<.>)) -import System.IO (IOMode (ReadMode)) -import System.IO (IOMode (WriteMode), +import System.IO (IOMode (ReadMode), + IOMode (WriteMode), withBinaryFile) -- | Download the given URL to the given location. If the file already exists, @@ -123,7 +124,7 @@ redownload req0 dest = do return True | responseStatus res == status304 -> return False - | otherwise -> throwM $ RedownloadFailed req2 dest $ fmap (const ()) res + | 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) diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs index 0f2cedab49..355cf8b403 100644 --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -157,7 +157,7 @@ sinkCheckHash req HashCheck{..} = do -- https://github.com/commercialhaskell/stack/issues/240 || b == actualDigestHexByteString - when (not passedCheck) $ + unless passedCheck $ throwM $ WrongDigest req (show hashCheckAlgorithm) hashCheckHexDigest actualDigestString assertLengthSink :: MonadThrow m @@ -200,7 +200,7 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do env <- ask liftIO $ whenM' getShouldDownload $ do createDirectoryIfMissing True dir - withBinaryFile fptmp WriteMode $ \h -> do + withBinaryFile fptmp WriteMode $ \h -> recovering drRetryPolicy handlers $ flip runReaderT env $ withResponse req (go h) @@ -254,7 +254,7 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do when (fileSize /= expectedFileSize) $ throwM $ WrongFileSize expectedFileSize fileSizeInteger - checkContentLengthHeader headers expectedContentLength = do + checkContentLengthHeader headers expectedContentLength = case List.lookup hContentLength headers of Just lengthBS -> do let lengthStr = displayByteString lengthBS diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs index c58880af2b..edf4266be0 100644 --- a/src/Options/Applicative/Builder/Extra.hs +++ b/src/Options/Applicative/Builder/Extra.hs @@ -20,30 +20,57 @@ import System.FilePath (takeBaseName) import Data.Text (Text) import qualified Data.Text as T --- | Enable/disable flags for a @Bool@. -boolFlags :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool +-- | Enable/disable flags for a 'Bool'. +boolFlags :: Bool -- ^ Default value + -> String -- ^ Flag name + -> String -- ^ Help suffix + -> Mod FlagFields Bool + -> Parser Bool boolFlags defaultValue = enableDisableFlags defaultValue True False --- | Enable/disable flags for a @Bool@, without a default case (to allow chaining @<|>@s). -boolFlagsNoDefault :: (Maybe Bool) -> String -> String -> Mod FlagFields Bool -> Parser Bool +-- | Enable/disable flags for a 'Bool', without a default case (to allow chaining with '<|>'). +boolFlagsNoDefault :: Maybe Bool -- ^ Hide the enabling or disabling flag from the + -- brief description? + -> String -- ^ Flag name + -> String -- ^ Help suffix + -> Mod FlagFields Bool + -> Parser Bool boolFlagsNoDefault = enableDisableFlagsNoDefault True False --- | Enable/disable flags for a @(Maybe Bool)@. -maybeBoolFlags :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (Maybe Bool) +-- | Enable/disable flags for a @('Maybe' 'Bool')@. +maybeBoolFlags :: String -- ^ Flag name + -> String -- ^ Help suffix + -> Mod FlagFields (Maybe Bool) + -> Parser (Maybe Bool) maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False) -- | Enable/disable flags for any type. -enableDisableFlags :: (Eq a) => a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a +enableDisableFlags :: (Eq a) + => a -- ^ Default value + -> a -- ^ Enabled value + -> a -- ^ Disabled value + -> String -- ^ Name + -> String -- ^ Help suffix + -> Mod FlagFields a + -> Parser a enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods = enableDisableFlagsNoDefault enabledValue disabledValue (Just defaultValue) name helpSuffix mods <|> pure defaultValue --- | Enable/disable flags for any type, without a default (to allow chaining @<|>@s) -enableDisableFlagsNoDefault :: (Eq a) => a -> a -> (Maybe a) -> String -> String -> Mod FlagFields a -> Parser a +-- | Enable/disable flags for any type, without a default (to allow chaining with '<|>') +enableDisableFlagsNoDefault :: (Eq a) + => a -- ^ Enabled value + -> a -- ^ Disabled value + -> Maybe a -- ^ Hide the enabling or disabling flag + -- from the brief description?? + -> String -- ^ Name + -> String -- ^ Help suffix + -> Mod FlagFields a + -> Parser a enableDisableFlagsNoDefault enabledValue disabledValue maybeHideValue name helpSuffix mods = last <$> some (enableDisableFlagsNoDefault' enabledValue disabledValue maybeHideValue name helpSuffix mods) -enableDisableFlagsNoDefault' :: (Eq a) => a -> a -> (Maybe a) -> String -> String -> Mod FlagFields a -> Parser a +enableDisableFlagsNoDefault' :: (Eq a) => a -> a -> Maybe a -> String -> String -> Mod FlagFields a -> Parser a enableDisableFlagsNoDefault' enabledValue disabledValue maybeHideValue name helpSuffix mods = let hideEnabled = Just enabledValue == maybeHideValue hideDisabled = Just disabledValue == maybeHideValue @@ -77,17 +104,29 @@ enableDisableFlagsNoDefault' enabledValue disabledValue maybeHideValue name help (hidden <> internal <> long ("disable-" ++ name) <> mods) -- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args). --- To actually show have that help appear, use 'execExtraHelp' before executing the main parser. -extraHelpOption :: String -> String -> String -> Parser (a -> a) -extraHelpOption progName fakeName helpName = +-- +-- To actually have that help appear, use 'execExtraHelp' before executing the main parser. +extraHelpOption :: Bool -- ^ Hide from the brief description? + -> String -- ^ Program name, e.g. @"stack"@ + -> String -- ^ Option glob expression, e.g. @"docker*"@ + -> String -- ^ Help option name, e.g. @"docker-help"@ + -> Parser (a -> a) +extraHelpOption hide progName fakeName helpName = infoOption (optDesc' ++ ".") (long helpName <> hidden <> internal) <*> - infoOption (optDesc' ++ ".") (long fakeName <> help optDesc') + infoOption (optDesc' ++ ".") (long fakeName <> + help optDesc' <> + (if hide then hidden <> internal else idm)) where optDesc' = concat ["Run '", takeBaseName progName, " --", helpName, "' for details"] --- | Display extra help if extea help option passed in arguments. --- Since optparse-applicative doesn't allow an arbirary IO action for an 'abortOption', this +-- | Display extra help if extra help option passed in arguments. +-- +-- Since optparse-applicative doesn't allow an arbitrary IO action for an 'abortOption', this -- was the best way I found that doesn't require manually formatting the help. -execExtraHelp :: [String] -> String -> Parser a -> String -> IO () +execExtraHelp :: [String] -- ^ Command line arguments + -> String -- ^ Extra help option name, e.g. @"docker-help"@ + -> Parser a -- ^ Option parser for the relevant command + -> String -- ^ Option description + -> IO () execExtraHelp args helpOpt parser pd = when (args == ["--" ++ helpOpt]) $ withArgs ["--help"] $ do @@ -99,8 +138,10 @@ execExtraHelp args helpOpt parser pd = return () where hiddenHelper = abortOption ShowHelpText (long "help" <> hidden <> internal) +-- | 'option', specialized to 'Text'. textOption :: Mod OptionFields Text -> Parser Text textOption = option (T.pack <$> readerAsk) +-- | 'argument', specialized to 'Text'. textArgument :: Mod ArgumentFields Text -> Parser Text textArgument = argument (T.pack <$> readerAsk) diff --git a/src/Options/Applicative/Complicated.hs b/src/Options/Applicative/Complicated.hs new file mode 100644 index 0000000000..d79f376748 --- /dev/null +++ b/src/Options/Applicative/Complicated.hs @@ -0,0 +1,141 @@ +-- | Simple interface to complicated program arguments. +-- +-- This is a "fork" of the @optparse-simple@ package that has some workarounds for +-- optparse-applicative issues that become problematic with programs that have many options and +-- subcommands. Because it makes the interface more complex, these workarounds are not suitable for +-- pushing upstream to optparse-applicative. + +module Options.Applicative.Complicated + ( addCommand + , addSubCommands + , complicatedOptions + , complicatedParser + ) where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Either +import Control.Monad.Trans.Writer +import Data.Monoid +import Data.Version +import Options.Applicative +import Options.Applicative.Types +import Options.Applicative.Builder.Internal +import System.Environment + +-- | Generate and execute a complicated options parser. +complicatedOptions + :: Monoid a + => Version + -- ^ numeric version + -> Maybe String + -- ^ version string + -> String + -- ^ header + -> String + -- ^ program description + -> Parser a + -- ^ common settings + -> EitherT b (Writer (Mod CommandFields (b,a))) () + -- ^ commands (use 'addCommand') + -> IO (a,b) +complicatedOptions numericVersion versionString h pd commonParser commandParser = + do args <- getArgs + (a,(b,c)) <- case execParserPure (prefs noBacktrack) parser args of + Failure _ | null args -> withArgs ["--help"] (execParser parser) + parseResult -> handleParseResult parseResult + return (mappend c a,b) + where parser = info (helpOption <*> versionOptions <*> complicatedParser commonParser commandParser) desc + desc = fullDesc <> header h <> progDesc pd + versionOptions = + case versionString of + Nothing -> versionOption (showVersion numericVersion) + Just s -> versionOption s <*> numericVersionOption + versionOption s = + infoOption + s + (long "version" <> + help "Show version") + numericVersionOption = + infoOption + (showVersion numericVersion) + (long "numeric-version" <> + help "Show only version number") + +-- | Add a command to the options dispatcher. +addCommand :: String -- ^ command string + -> String -- ^ title of command + -> String -- ^ footer of command help + -> (a -> b) -- ^ constructor to wrap up command in common data type + -> Parser c -- ^ common parser + -> Parser a -- ^ command parser + -> EitherT b (Writer (Mod CommandFields (b,c))) () +addCommand cmd title footerStr constr = + addCommand' cmd title footerStr (\a c -> (constr a,c)) + +-- | Add a command that takes sub-commands to the options dispatcher. +addSubCommands + :: Monoid c + => String + -- ^ command string + -> String + -- ^ title of command + -> String + -- ^ footer of command help + -> Parser c + -- ^ common parser + -> EitherT b (Writer (Mod CommandFields (b,c))) () + -- ^ sub-commands (use 'addCommand') + -> EitherT b (Writer (Mod CommandFields (b,c))) () +addSubCommands cmd title footerStr commonParser commandParser = + addCommand' cmd + title + footerStr + (\(c1,(a,c2)) c3 -> (a,mconcat [c3, c2, c1])) + commonParser + (complicatedParser commonParser commandParser) + +-- | Add a command to the options dispatcher. +addCommand' :: String -- ^ command string + -> String -- ^ title of command + -> String -- ^ footer of command help + -> (a -> c -> (b,c)) -- ^ constructor to wrap up command in common data type + -> Parser c -- ^ common parser + -> Parser a -- ^ command parser + -> EitherT b (Writer (Mod CommandFields (b,c))) () +addCommand' cmd title footerStr constr commonParser inner = + lift (tell (command cmd + (info (constr <$> inner <*> commonParser) + (progDesc title <> footer footerStr)))) + +-- | Generate a complicated options parser. +complicatedParser + :: Monoid a + => Parser a + -- ^ common settings + -> EitherT b (Writer (Mod CommandFields (b,a))) () + -- ^ commands (use 'addCommand') + -> Parser (a,(b,a)) +complicatedParser commonParser commandParser = + (,) <$> + commonParser <*> + case runWriter (runEitherT commandParser) of + (Right (),d) -> hsubparser' d + (Left b,_) -> pure (b,mempty) + +-- way to do in 'addCommand' | Subparser with @--help@ argument. Borrowed with slight modification +-- from Options.Applicative.Extra. +hsubparser' :: Mod CommandFields a -> Parser a +hsubparser' m = mkParser d g rdr + where + Mod _ d g = m `mappend` metavar "COMMAND" + (cmds, subs) = mkCommand m + rdr = CmdReader cmds (fmap add_helper . subs) + add_helper pinfo = pinfo + { infoParser = infoParser pinfo <**> helpOption } + +-- | Non-hidden help option. +helpOption :: Parser (a -> a) +helpOption = + abortOption ShowHelpText $ + long "help" <> + help "Show this help text" diff --git a/src/Path/Extra.hs b/src/Path/Extra.hs index 1f81aca912..e203fde5bf 100644 --- a/src/Path/Extra.hs +++ b/src/Path/Extra.hs @@ -46,8 +46,8 @@ collapseFilePath = FP.joinPath . reverse . foldl go [] . FP.splitDirectories where go rs "." = rs go r@(p:rs) ".." = case p of - ".." -> ("..":r) - (checkPathSeperator -> Just True) -> ("..":r) + ".." -> "..":r + (checkPathSeperator -> Just True) -> "..":r _ -> rs go _ (checkPathSeperator -> Just True) = [[FP.pathSeparator]] go rs x = x:rs diff --git a/src/Path/Find.hs b/src/Path/Find.hs index 15f9b8b716..7a88e3182b 100644 --- a/src/Path/Find.hs +++ b/src/Path/Find.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -- | Finding files. @@ -23,7 +22,7 @@ findFileUp :: (MonadIO m,MonadThrow m) -> (Path Abs File -> Bool) -- ^ Predicate to match the file. -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. -> m (Maybe (Path Abs File)) -- ^ Absolute file path. -findFileUp s p d = findPathUp snd s p d +findFileUp = findPathUp snd -- | Find the location of a directory matching the given predicate. findDirUp :: (MonadIO m,MonadThrow m) @@ -31,7 +30,7 @@ findDirUp :: (MonadIO m,MonadThrow m) -> (Path Abs Dir -> Bool) -- ^ Predicate to match the directory. -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. -> m (Maybe (Path Abs Dir)) -- ^ Absolute directory path. -findDirUp s p d = findPathUp fst s p d +findDirUp = findPathUp fst -- | Find the location of a path matching the given predicate. findPathUp :: (MonadIO m,MonadThrow m) diff --git a/src/Path/IO.hs b/src/Path/IO.hs index c5cadceb44..745ac1bf03 100644 --- a/src/Path/IO.hs +++ b/src/Path/IO.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ViewPatterns #-} -- | IO actions that might be put in a package at some point. @@ -40,7 +39,7 @@ import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Data.Either -import Data.Maybe +import Data.Maybe.Extra import Data.Typeable import Path import qualified System.Directory as D @@ -135,8 +134,8 @@ resolveFileMaybe = resolveCheckParse D.doesFileExist parseAbsFile listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File]) listDirectory dir = do entriesFP <- liftIO (D.getDirectoryContents dirFP) - maybeEntries <- - forM (map (dirFP ++) entriesFP) + entries <- + forMaybeM (map (dirFP ++) entriesFP) (\entryFP -> do isDir <- liftIO (D.doesDirectoryExist entryFP) if isDir @@ -149,7 +148,6 @@ listDirectory dir = else case parseAbsFile entryFP of Nothing -> return Nothing Just entryFile -> return (Just (Right entryFile))) - let entries = catMaybes maybeEntries return (lefts entries,rights entries) where dirFP = toFilePath dir diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index abbce03929..0a9d739545 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -10,7 +10,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} --- | Build project(s). +-- | Build the project. module Stack.Build (build @@ -29,14 +29,15 @@ import Control.Monad.Trans.Resource import Data.Aeson (Value (Object, Array), (.=), object) import Data.Function import qualified Data.HashMap.Strict as HM +import Data.IORef.RunOnce (runOnce) import qualified Data.Map as Map import Data.Map.Strict (Map) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.IO as TIO import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text.IO as TIO import Data.Text.Read (decimal) import qualified Data.Vector as V import qualified Data.Yaml as Yaml @@ -162,7 +163,7 @@ withLoadPackage :: ( MonadIO m -> m a withLoadPackage menv inner = do econfig <- asks getEnvConfig - withCabalLoader menv $ \cabalLoader -> + withCabalLoader' <- runOnce $ withCabalLoader menv $ \cabalLoader -> inner $ \name version flags -> do bs <- cabalLoader $ PackageIdentifier name version -- TODO automatically update index the first time this fails @@ -171,6 +172,7 @@ withLoadPackage menv inner = do -- resolving the package index. (_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags) bs return pkg + withCabalLoader' where -- | Package config to be used for dependencies depPackageConfig :: EnvConfig -> Map FlagName Bool -> PackageConfig @@ -244,7 +246,7 @@ fixCodePage' inner = do queryBuildInfo :: M env m => [Text] -- ^ selectors -> m () -queryBuildInfo selectors0 = do +queryBuildInfo selectors0 = rawBuildInfo >>= select id selectors0 >>= liftIO . TIO.putStrLn . decodeUtf8 . Yaml.encode diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 2a38ee60ab..f5e2fa90c4 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -21,12 +21,6 @@ module Stack.Build.Cache , setTestSuccess , unsetTestSuccess , checkTestSuccess - , setTestBuilt - , unsetTestBuilt - , checkTestBuilt - , setBenchBuilt - , unsetBenchBuilt - , checkBenchBuilt , writePrecompiledCache , readPrecompiledCache ) where @@ -121,7 +115,9 @@ tryGetCache :: (MonadIO m, BinarySchema a) => (Path Abs Dir -> m (Path Abs File)) -> Path Abs Dir -> m (Maybe a) -tryGetCache get' dir = get' dir >>= decodeFileOrFailDeep . toFilePath +tryGetCache get' dir = do + fp <- get' dir + 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) @@ -130,9 +126,9 @@ writeBuildCache dir times = writeCache dir buildCacheFile - (BuildCache + BuildCache { buildCacheTimes = times - }) + } -- | Write the dirtiness cache for this package's configuration. writeConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env) @@ -167,7 +163,7 @@ writeCache :: (BinarySchema a, MonadIO m) -> m () writeCache dir get' content = do fp <- get' dir - taggedEncodeFile (toFilePath fp) content + taggedEncodeFile fp content flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) => Installed @@ -184,8 +180,9 @@ flagCacheFile installed = do tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) => Installed -> m (Maybe ConfigCache) -tryGetFlagCache gid = - flagCacheFile gid >>= decodeFileOrFailDeep . toFilePath +tryGetFlagCache gid = do + fp <- flagCacheFile gid + decodeFileOrFailDeep fp writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m) => Installed @@ -195,7 +192,7 @@ writeFlagCache gid cache = do file <- flagCacheFile gid liftIO $ do createTree (parent file) - taggedEncodeFile (toFilePath file) cache + taggedEncodeFile file cache -- | Mark a test suite as having succeeded setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) @@ -226,64 +223,6 @@ checkTestSuccess dir = (fromMaybe False) (tryGetCache testSuccessFile dir) --- | Mark a test suite as having built -setTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) - => Path Abs Dir - -> m () -setTestBuilt dir = - writeCache - dir - testBuiltFile - True - --- | Mark a test suite as not having built -unsetTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) - => Path Abs Dir - -> m () -unsetTestBuilt dir = - writeCache - dir - testBuiltFile - False - --- | Check if the test suite already built -checkTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) - => Path Abs Dir - -> m Bool -checkTestBuilt dir = - liftM - (fromMaybe False) - (tryGetCache testBuiltFile dir) - --- | Mark a bench suite as having built -setBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) - => Path Abs Dir - -> m () -setBenchBuilt dir = - writeCache - dir - benchBuiltFile - True - --- | Mark a bench suite as not having built -unsetBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) - => Path Abs Dir - -> m () -unsetBenchBuilt dir = - writeCache - dir - benchBuiltFile - False - --- | Check if the bench suite already built -checkBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) - => Path Abs Dir - -> m Bool -checkBenchBuilt dir = - liftM - (fromMaybe False) - (tryGetCache benchBuiltFile dir) - -------------------------------------- -- Precompiled Cache -- @@ -357,7 +296,7 @@ writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do exes' <- forM (Set.toList exes) $ \exe -> do name <- parseRelFile $ T.unpack exe return $ toFilePath $ bcoSnapInstallRoot baseConfigOpts bindirSuffix name - liftIO $ taggedEncodeFile (toFilePath file) PrecompiledCache + liftIO $ taggedEncodeFile file PrecompiledCache { pcLibrary = mlibpath , pcExes = exes' } @@ -371,4 +310,4 @@ readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, Mona -> m (Maybe PrecompiledCache) readPrecompiledCache pkgident copts depIDs = do file <- precompiledCacheFile pkgident copts depIDs - decodeFileOrFailDeep $ toFilePath file + decodeFileOrFailDeep file diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index a4de022d91..ff18d42d25 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -34,7 +34,7 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Distribution.Package (Dependency (..)) -import Distribution.Version (anyVersion) +import Distribution.Version (anyVersion) import Network.HTTP.Client.Conduit (HasHttpManager) import Prelude hiding (pi, writeFile) import Stack.Build.Cache @@ -45,7 +45,6 @@ import Stack.Types.Build import Stack.BuildPlan import Stack.Package import Stack.PackageDump -import Stack.PackageIndex import Stack.Types data PackageInfo @@ -70,7 +69,7 @@ combineMap :: SourceMap -> InstalledMap -> CombinedMap combineMap = Map.mergeWithKey (\_ s i -> Just $ combineSourceInstalled s i) (fmap PIOnlySource) - (fmap (\(l, i) -> PIOnlyInstalled l i)) + (fmap (uncurry PIOnlyInstalled)) data AddDepRes = ADRToInstall Task @@ -78,7 +77,7 @@ data AddDepRes deriving Show data W = W - { wFinals :: !(Map PackageName (Either ConstructPlanException (Task, LocalPackageTB))) + { wFinals :: !(Map PackageName (Either ConstructPlanException Task)) , wInstall :: !(Map Text InstallLocation) -- ^ executable to be installed, and location where the binary is placed , wDirty :: !(Map PackageName Text) @@ -134,19 +133,14 @@ constructPlan :: forall env m. -> m Plan constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap = do let locallyRegistered = Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localDumpPkgs - menv <- getMinimalEnvOverride - caches <- getPackageCaches menv - let latest = Map.fromListWith max $ map toTuple $ Map.keys caches + bconfig <- asks getBuildConfig + let latest = + Map.fromListWith max $ + map toTuple $ + Map.keys (bcPackageCaches bconfig) econfig <- asks getEnvConfig - let onWanted lp = do - case lpExeComponents lp of - Nothing -> return () - Just _ -> void $ addDep False $ packageName $ lpPackage lp - - case lpTestBench lp of - Just tb -> addFinal lp tb - Nothing -> return () + let onWanted = void . addDep False . packageName . lpPackage let inner = do mapM_ onWanted $ filter lpWanted locals mapM_ (addDep False) $ Set.toList extraToBuild0 @@ -185,7 +179,7 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag , loadPackage = loadPackage0 , combinedMap = combineMap sourceMap installedMap , toolToPackages = \ (Dependency name _) -> - maybe Map.empty (Map.fromSet (\_ -> anyVersion)) $ + maybe Map.empty (Map.fromSet (const anyVersion)) $ Map.lookup (S8.pack . packageNameString . fromCabalPackageName $ name) toolMap , ctxEnvConfig = econfig , callStack = [] @@ -225,14 +219,14 @@ mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap = where name = packageIdentifierName ident -addFinal :: LocalPackage -> LocalPackageTB -> M () -addFinal lp lptb = do +addFinal :: LocalPackage -> Package -> Bool -> M () +addFinal lp package isAllInOne = do depsRes <- addPackageDeps False package res <- case depsRes of Left e -> return $ Left e Right (missing, present, _minLoc) -> do ctx <- ask - return $ Right (Task + return $ Right Task { taskProvides = PackageIdentifier (packageName package) (packageVersion package) @@ -248,13 +242,13 @@ addFinal lp lptb = do package , taskPresent = present , taskType = TTLocal lp - }, lptb) + , taskAllInOne = isAllInOne + } tell mempty { wFinals = Map.singleton (packageName package) res } - where - package = lptbPackage lptb addDep :: Bool -- ^ is this being used by a dependency? - -> PackageName -> M (Either ConstructPlanException AddDepRes) + -> PackageName + -> M (Either ConstructPlanException AddDepRes) addDep treatAsDep' name = do ctx <- ask let treatAsDep = treatAsDep' || name `Set.notMember` wanted ctx @@ -263,46 +257,31 @@ addDep treatAsDep' name = do case Map.lookup name m of Just res -> return res Nothing -> do - res <- addDep' treatAsDep name + res <- if name `elem` callStack ctx + then return $ Left $ DependencyCycleDetected $ name : callStack ctx + else local (\ctx' -> ctx' { callStack = name : callStack ctx' }) $ + case Map.lookup name $ combinedMap ctx of + -- TODO look up in the package index and see if there's a + -- recommendation available + Nothing -> return $ Left $ UnknownPackage name + Just (PIOnlyInstalled loc installed) -> do + -- slightly hacky, no flags since they likely won't affect executable names + tellExecutablesUpstream name (installedVersion installed) loc Map.empty + return $ Right $ ADRFound loc installed + Just (PIOnlySource ps) -> do + tellExecutables name ps + installPackage treatAsDep name ps Nothing + Just (PIBoth ps installed) -> do + tellExecutables name ps + installPackage treatAsDep name ps (Just installed) modify $ Map.insert name res return res -addDep' :: Bool -- ^ is this being used by a dependency? - -> PackageName -> M (Either ConstructPlanException AddDepRes) -addDep' treatAsDep name = do - ctx <- ask - if name `elem` callStack ctx - then return $ Left $ DependencyCycleDetected $ name : callStack ctx - else local - (\ctx' -> ctx' { callStack = name : callStack ctx' }) $ do - (addDep'' treatAsDep name) - -addDep'' :: Bool -- ^ is this being used by a dependency? - -> PackageName -> M (Either ConstructPlanException AddDepRes) -addDep'' treatAsDep name = do - ctx <- ask - case Map.lookup name $ combinedMap ctx of - -- TODO look up in the package index and see if there's a - -- recommendation available - Nothing -> return $ Left $ UnknownPackage name - Just (PIOnlyInstalled loc installed) -> do - tellExecutablesUpstream name (installedVersion installed) loc Map.empty -- slightly hacky, no flags since they likely won't affect executable names - return $ Right $ ADRFound loc installed - Just (PIOnlySource ps) -> do - tellExecutables name ps - installPackage treatAsDep name ps - Just (PIBoth ps installed) -> do - tellExecutables name ps - needInstall <- checkNeedInstall treatAsDep name ps installed (wanted ctx) - if needInstall - then installPackage treatAsDep name ps - else return $ Right $ ADRFound (piiLocation ps) installed - -tellExecutables :: PackageName -> PackageSource -> M () -- TODO merge this with addFinal above? +tellExecutables :: PackageName -> PackageSource -> M () tellExecutables _ (PSLocal lp) | lpWanted lp = tellExecutablesPackage Local $ lpPackage lp | otherwise = return () -tellExecutables name (PSUpstream version loc flags) = do +tellExecutables name (PSUpstream version loc flags) = tellExecutablesUpstream name version loc flags tellExecutablesUpstream :: PackageName -> Version -> InstallLocation -> Map FlagName Bool -> M () @@ -323,70 +302,122 @@ tellExecutablesPackage loc p = do Just (PIOnlySource ps) -> goSource ps Just (PIBoth ps _) -> goSource ps - goSource (PSLocal lp) = fromMaybe Set.empty $ lpExeComponents lp - goSource (PSUpstream _ _ _) = Set.empty + goSource (PSLocal lp) + | lpWanted lp = exeComponents (lpComponents lp) + | otherwise = Set.empty + goSource (PSUpstream{}) = Set.empty - tell mempty { wInstall = m myComps } + tell mempty { wInstall = Map.fromList $ map (, loc) $ Set.toList $ filterComps myComps $ packageExes p } where - m myComps = Map.fromList $ map (, loc) $ Set.toList - $ filterComps myComps $ packageExes p - filterComps myComps x | Set.null myComps = x - | otherwise = Set.intersection x $ Set.map toExe myComps - - toExe x = fromMaybe x $ T.stripPrefix "exe:" x - --- TODO There are a lot of duplicated computations below. I've kept that for --- simplicity right now + | otherwise = Set.intersection x myComps installPackage :: Bool -- ^ is this being used by a dependency? - -> PackageName -> PackageSource -> M (Either ConstructPlanException AddDepRes) -installPackage treatAsDep name ps = do + -> PackageName + -> PackageSource + -> Maybe Installed + -> M (Either ConstructPlanException AddDepRes) +installPackage treatAsDep name ps minstalled = do ctx <- ask - package <- psPackage name ps - depsRes <- addPackageDeps treatAsDep package - case depsRes of - Left e -> return $ Left e - Right (missing, present, minLoc) -> do - return $ Right $ ADRToInstall Task - { taskProvides = PackageIdentifier - (packageName package) - (packageVersion package) - , taskConfigOpts = TaskConfigOpts missing $ \missing' -> - let allDeps = Map.union present missing' - destLoc = piiLocation ps <> minLoc - in configureOpts - (getEnvConfig ctx) - (baseConfigOpts ctx) - allDeps - (psWanted ps) - (psLocal ps) - -- An assertion to check for a recurrence of - -- https://github.com/commercialhaskell/stack/issues/345 - (assert (destLoc == piiLocation ps) destLoc) - package - , taskPresent = present - , taskType = - case ps of - PSLocal lp -> TTLocal lp - PSUpstream _ loc _ -> TTUpstream package $ loc <> minLoc - } - -checkNeedInstall :: Bool - -> PackageName -> PackageSource -> Installed -> Set PackageName -> M Bool -checkNeedInstall treatAsDep name ps installed wanted = assert (piiLocation ps == Local) $ do - package <- psPackage name ps - depsRes <- addPackageDeps treatAsDep package - case depsRes of - Left _e -> return True -- installPackage will find the error again - Right (missing, present, _loc) - | Set.null missing -> checkDirtiness ps installed package present wanted - | otherwise -> do - tell mempty { wDirty = Map.singleton name $ - let t = T.intercalate ", " $ map (T.pack . packageNameString . packageIdentifierName) (Set.toList missing) - in T.append "missing dependencies: " $ addEllipsis t } - return True + case ps of + PSUpstream version _ flags -> do + package <- liftIO $ loadPackage ctx name version flags + resolveDepsAndInstall False treatAsDep ps package minstalled + PSLocal lp -> + case lpTestBench lp of + Nothing -> resolveDepsAndInstall False treatAsDep ps (lpPackage lp) minstalled + Just tb -> do + -- Attempt to find a plan which performs an all-in-one + -- build. Ignore the writer action + reset the state if + -- it fails. + s <- get + res <- pass $ do + res <- addPackageDeps treatAsDep tb + let writerFunc w = case res of + Left _ -> mempty + _ -> w + return (res, writerFunc) + case res of + Right deps -> do + adr <- installPackageGivenDeps True ps tb minstalled deps + -- FIXME: this redundantly adds the deps (but + -- they'll all just get looked up in the map) + addFinal lp tb True + return $ Right adr + Left _ -> do + -- Reset the state to how it was before + -- attempting to find an all-in-one build + -- plan. + put s + -- Otherwise, fall back on building the + -- tests / benchmarks in a separate step. + res' <- resolveDepsAndInstall False treatAsDep ps (lpPackage lp) minstalled + when (isRight res') $ do + -- Insert it into the map so that it's + -- available for addFinal. + modify $ Map.insert name res' + addFinal lp tb False + return res' + +resolveDepsAndInstall :: Bool + -> Bool + -> PackageSource + -> Package + -> Maybe Installed + -> M (Either ConstructPlanException AddDepRes) +resolveDepsAndInstall isAllInOne treatAsDep ps package minstalled = do + res <- addPackageDeps treatAsDep package + case res of + Left err -> return $ Left err + Right deps -> liftM Right $ installPackageGivenDeps isAllInOne ps package minstalled deps + +installPackageGivenDeps :: Bool + -> PackageSource + -> Package + -> Maybe Installed + -> ( Set PackageIdentifier + , Map PackageIdentifier GhcPkgId + , InstallLocation ) + -> M AddDepRes +installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minLoc) = do + let name = packageName package + ctx <- ask + mRightVersionInstalled <- case (minstalled, Set.null missing) of + (Just installed, True) -> do + shouldInstall <- checkDirtiness ps installed package present (wanted ctx) + return $ if shouldInstall then Nothing else Just installed + (Just _, False) -> do + let t = T.intercalate ", " $ map (T.pack . packageNameString . packageIdentifierName) (Set.toList missing) + tell mempty { wDirty = Map.singleton name $ "missing dependencies: " <> addEllipsis t } + return Nothing + (Nothing, _) -> return Nothing + return $ case mRightVersionInstalled of + Just installed -> ADRFound (piiLocation ps) installed + Nothing -> ADRToInstall Task + { taskProvides = PackageIdentifier + (packageName package) + (packageVersion package) + , taskConfigOpts = TaskConfigOpts missing $ \missing' -> + let allDeps = Map.union present missing' + destLoc = piiLocation ps <> minLoc + in configureOpts + (getEnvConfig ctx) + (baseConfigOpts ctx) + allDeps + (psWanted ps) + (psLocal ps) + -- An assertion to check for a recurrence of + -- https://github.com/commercialhaskell/stack/issues/345 + (assert (destLoc == piiLocation ps) destLoc) + package + , taskPresent = present + , taskType = + case ps of + PSLocal lp -> TTLocal lp + PSUpstream _ loc _ -> TTUpstream package $ loc <> minLoc + , taskAllInOne = isAllInOne + } addEllipsis :: Text -> Text addEllipsis t @@ -412,7 +443,7 @@ addPackageDeps treatAsDep package = do inRange <- if adrVersion adr `withinRange` range then return True else do - let warn reason = do + let warn reason = tell mempty { wWarnings = (msg:) } where msg = T.concat @@ -482,7 +513,7 @@ checkDirtiness ps installed package present wanted = do , configCacheComponents = case ps of PSLocal lp -> Set.map renderComponent $ lpComponents lp - PSUpstream _ _ _ -> Set.empty + PSUpstream{} -> Set.empty , configCacheHaddock = shouldHaddockPackage buildOpts wanted (packageName package) || -- Disabling haddocks when old config had haddocks doesn't make dirty. @@ -576,21 +607,15 @@ describeConfigDiff config old new psDirty :: PackageSource -> Maybe (Set FilePath) psDirty (PSLocal lp) = lpDirtyFiles lp -psDirty (PSUpstream _ _ _) = Nothing -- files never change in an upstream package +psDirty (PSUpstream {}) = Nothing -- files never change in an upstream package psWanted :: PackageSource -> Bool psWanted (PSLocal lp) = lpWanted lp -psWanted (PSUpstream _ _ _) = False +psWanted (PSUpstream {}) = False psLocal :: PackageSource -> Bool psLocal (PSLocal _) = True -psLocal (PSUpstream _ _ _) = False - -psPackage :: PackageName -> PackageSource -> M Package -psPackage _ (PSLocal lp) = return $ lpPackage lp -psPackage name (PSUpstream version _ flags) = do - ctx <- ask - liftIO $ loadPackage ctx name version flags +psLocal (PSUpstream {}) = False -- | Get all of the dependencies for a given package, including guessed build -- tool dependencies. diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 01808a5d88..d388544301 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -37,13 +37,14 @@ import qualified Data.ByteString.Char8 as S8 import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL -import Data.Foldable (forM_) +import Data.Foldable (forM_, any) import Data.Function import Data.IORef.RunOnce (runOnce) -import Data.List +import Data.List hiding (any) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Maybe.Extra (forMaybeM) import Data.Monoid ((<>)) import Data.Set (Set) import qualified Data.Set as Set @@ -52,6 +53,7 @@ import qualified Data.Streaming.Process as Process import Data.Traversable (forM) import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock (getCurrentTime) import Data.Word8 (_colon) import Distribution.System (OS (Windows), @@ -61,7 +63,7 @@ import Language.Haskell.TH as TH (location) import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.IO -import Prelude hiding (FilePath, writeFile) +import Prelude hiding (FilePath, writeFile, any) import Stack.Build.Cache import Stack.Build.Haddock import Stack.Build.Installed @@ -92,6 +94,7 @@ import System.Process.Internals (createProcess_) type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) +-- | Fetch the packages necessary for a build, for example in combination with a dry run. preFetch :: M env m => Plan -> m () preFetch plan | Set.null idents = $logDebug "Nothing to fetch" @@ -111,6 +114,7 @@ preFetch plan name (packageVersion package) +-- | Print a description of build plan for human consumption. printPlan :: M env m => Plan -> m () @@ -138,10 +142,10 @@ printPlan plan = do $logInfo "Would build:" mapM_ ($logInfo . displayTask) xs - let hasTests = not . Set.null . lptbTests - hasBenches = not . Set.null . lptbBenches - tests = Map.elems $ fmap fst $ Map.filter (hasTests . snd) $ planFinals plan - benches = Map.elems $ fmap fst $ Map.filter (hasBenches . snd) $ planFinals plan + let hasTests = not . Set.null . testComponents . taskComponents + hasBenches = not . Set.null . benchComponents . taskComponents + tests = Map.elems $ Map.filter hasTests $ planFinals plan + benches = Map.elems $ Map.filter hasBenches $ planFinals plan unless (null tests) $ do $logInfo "" @@ -275,6 +279,7 @@ getSetupExe setupHs tmpdir = do renameFile tmpExePath exePath return $ Just exePath +-- | Execute a callback that takes an 'ExecuteEnv'. withExecuteEnv :: M env m => EnvOverride -> BuildOpts @@ -364,7 +369,7 @@ executePlan menv bopts baseConfigOpts locals globalPackages snapshotPackages loc currExe <- liftIO getExecutablePath -- needed for windows, see below - installed <- forM (Map.toList $ planInstallExes plan) $ \(name, loc) -> do + installed <- forMaybeM (Map.toList $ planInstallExes plan) $ \(name, loc) -> do let bindir = case loc of Snap -> snapBin @@ -394,7 +399,7 @@ executePlan menv bopts baseConfigOpts locals globalPackages snapshotPackages loc _ -> D.copyFile (toFilePath file) destFile return $ Just (destDir', [T.append name (T.pack ext)]) - let destToInstalled = Map.fromListWith (++) (catMaybes installed) + let destToInstalled = Map.fromListWith (++) installed unless (Map.null destToInstalled) $ $logInfo "" forM_ (Map.toList destToInstalled) $ \(dest, executables) -> do $logInfo $ T.concat @@ -505,7 +510,7 @@ executePlan' installedMap0 plan ee@ExecuteEnv {..} = do when (boptsHaddock eeBuildOpts) $ do snapshotDumpPkgs <- liftIO (readTVarIO eeSnapshotDumpPkgs) localDumpPkgs <- liftIO (readTVarIO eeLocalDumpPkgs) - generateLocalHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeLocals + generateLocalHaddockIndex eeEnvOverride wc eeBaseConfigOpts localDumpPkgs eeLocals generateDepsHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals generateSnapHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs where @@ -519,7 +524,7 @@ toActions :: M env m => InstalledMap -> (m () -> IO ()) -> ExecuteEnv - -> (Maybe Task, Maybe (Task, LocalPackageTB)) -- build and final + -> (Maybe Task, Maybe Task) -- build and final -> [Action] toActions installedMap runInBase ee (mbuild, mfinal) = abuild ++ afinal @@ -532,39 +537,60 @@ toActions installedMap runInBase ee (mbuild, mfinal) = { actionId = ActionId taskProvides ATBuild , actionDeps = (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)) - , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap + , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap False } ] afinal = case mfinal of Nothing -> [] - Just (task@Task {..}, lptb) -> + Just task@Task {..} -> + (if taskAllInOne then [] else + [Action + { actionId = ActionId taskProvides ATBuildFinal + , actionDeps = addBuild ATBuild + (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)) + , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap True + }]) ++ [ Action { actionId = ActionId taskProvides ATFinal - , actionDeps = addBuild taskProvides $ - (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)) + , actionDeps = addBuild (if taskAllInOne then ATBuild else ATBuildFinal) Set.empty , actionDo = \ac -> runInBase $ do - unless (Set.null $ lptbTests lptb) $ do - singleTest runInBase topts lptb ac ee task installedMap - unless (Set.null $ lptbBenches lptb) $ do - singleBench runInBase beopts lptb ac ee task installedMap + let comps = taskComponents task + tests = testComponents comps + benches = benchComponents comps + unless (Set.null tests) $ do + singleTest runInBase topts (Set.toList tests) ac ee task installedMap + unless (Set.null benches) $ do + -- FIXME: shouldn't this use the list of benchmarks to run? + singleBench runInBase beopts ac ee task installedMap } ] - where - addBuild ident = - case mbuild of - Nothing -> id - Just _ -> Set.insert $ ActionId ident ATBuild - + where + addBuild aty = + case mbuild of + Nothing -> id + Just _ -> Set.insert $ ActionId taskProvides aty bopts = eeBuildOpts ee topts = boptsTestOpts bopts beopts = boptsBenchmarkOpts bopts -- | Generate the ConfigCache getConfigCache :: MonadIO m - => ExecuteEnv -> Task -> [Text] + => ExecuteEnv -> Task -> InstalledMap -> Bool -> Bool -> m (Map PackageIdentifier GhcPkgId, ConfigCache) -getConfigCache ExecuteEnv {..} Task {..} extra = do +getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = do + let extra = + -- We enable tests if the test suite dependencies are already + -- installed, so that we avoid unnecessary recompilation based on + -- cabal_macros.h changes when switching between 'stack build' and + -- 'stack test'. See: + -- https://github.com/commercialhaskell/stack/issues/805 + case taskType of + TTLocal lp -> concat + [ ["--enable-tests" | enableTest || (depsPresent installedMap $ lpTestDeps lp)] + , ["--enable-benchmarks" | enableBench || (depsPresent installedMap $ lpBenchDeps lp)] + ] + _ -> [] idMap <- liftIO $ readTVarIO eeGhcPkgIds let getMissing ident = case Map.lookup ident idMap of @@ -735,6 +761,9 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md eeCabalPkgVer) packageArgs = case mdeps of + -- This branch is taken when + -- 'explicit-setup-deps' is requested in your + -- stack.yaml file. Just deps | explicitSetupDeps (packageName package) config -> -- Stack always builds with the global Cabal for various -- reproducibility issues. @@ -753,7 +782,10 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md : cabalPackageArg : map ("-package-id=" ++) depsMinusCabal ) - -- This branch is debatable. It adds access to the + -- This branch is usually taken for builds, and + -- is always taken for `stack sdist`. + -- + -- This approach is debatable. It adds access to the -- snapshot package database for Cabal. There are two -- possible objections: -- @@ -785,8 +817,8 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md ec <- liftIO $ - withAsync (runInBase $ maybePrintBuildOutput stripTHLoading makeAbsolute LevelInfo mlogFile moutH) $ \outThreadID -> - withAsync (runInBase $ maybePrintBuildOutput False makeAbsolute LevelWarn mlogFile merrH) $ \errThreadID -> do + withAsync (runInBase $ maybePrintBuildOutput stripTHLoading makeAbsolute pkgDir LevelInfo mlogFile moutH) $ \outThreadID -> + withAsync (runInBase $ maybePrintBuildOutput False makeAbsolute pkgDir LevelWarn mlogFile merrH) $ \errThreadID -> do ec <- waitForProcess ph wait errThreadID wait outThreadID @@ -856,12 +888,12 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md return (outputFile, setupArgs) runExe exeName $ (if boptsCabalVerbose eeBuildOpts then ("--verbose":) else id) fullArgs - maybePrintBuildOutput stripTHLoading makeAbsolute level mlogFile mh = + maybePrintBuildOutput stripTHLoading makeAbsolute pkgDir level mlogFile mh = case mh of Just h -> case mlogFile of Just{} -> return () - Nothing -> printBuildOutput stripTHLoading makeAbsolute level h + Nothing -> printBuildOutput stripTHLoading makeAbsolute pkgDir level h Nothing -> return () singleBuild :: M env m @@ -870,9 +902,10 @@ singleBuild :: M env m -> ExecuteEnv -> Task -> InstalledMap + -> Bool -- ^ Is this a final build? -> m () -singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap = do - (allDepsMap, cache) <- getCache +singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap isFinalBuild = do + (allDepsMap, cache) <- getConfigCache ee task installedMap enableTests enableBenchmarks mprecompiled <- getPrecompiled cache minstalled <- case mprecompiled of @@ -887,34 +920,46 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in pname = packageIdentifierName taskProvides shouldHaddockPackage' = shouldHaddockPackage eeBuildOpts eeWanted pname doHaddock package = shouldHaddockPackage' && + not isFinalBuild && -- Works around haddock failing on bytestring-builder since it has no modules -- when bytestring is new enough. packageHasExposedModules package - getCache = do - let extra = - -- We enable tests if the test suite dependencies are already - -- installed, so that we avoid unnecessary recompilation based on - -- cabal_macros.h changes when switching between 'stack build' and - -- 'stack test'. See: - -- https://github.com/commercialhaskell/stack/issues/805 - case taskType of - TTLocal lp -> concat - [ ["--enable-tests" | depsPresent installedMap $ lpTestDeps lp] - , ["--enable-benchmarks" | depsPresent installedMap $ lpBenchDeps lp] - ] - _ -> [] - getConfigCache ee task extra + buildingFinals = isFinalBuild || taskAllInOne + enableTests = buildingFinals && any isCTest (taskComponents task) + enableBenchmarks = buildingFinals && any isCBench (taskComponents task) + + annSuffix = if result == "" then "" else " (" <> result <> ")" + where + result = T.intercalate " + " $ concat $ + [ ["lib" | taskAllInOne && hasLib] + , ["exe" | taskAllInOne && hasExe] + , ["test" | enableTests] + , ["bench" | enableBenchmarks] + ] + (hasLib, hasExe) = case taskType of + TTLocal lp -> (packageHasLibrary (lpPackage lp), not (Set.null (exesToBuild lp))) + -- This isn't true, but we don't want to have this info for + -- upstream deps. + TTUpstream{} -> (False, False) getPrecompiled cache = case taskLocation task of - Snap | not shouldHaddockPackage' -> do + Snap -> do mpc <- readPrecompiledCache taskProvides (configCacheOpts cache) (configCacheDeps cache) case mpc of Nothing -> return Nothing - Just pc -> do + 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 + Just pc | otherwise -> do let allM _ [] = return True allM f (x:xs) = do b <- f x @@ -937,6 +982,17 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in $ Map.insert "GHC_PACKAGE_PATH" (T.pack $ toFilePath $ bcoSnapDB eeBaseConfigOpts) + + -- In case a build of the library with different flags already exists, unregister it + -- before copying. + catch + (readProcessNull Nothing menv' "ghc-pkg" + [ "unregister" + , "--force" + , packageIdentifierString taskProvides + ]) + (\(ReadProcessException _ _ _ _) -> return ()) + readProcessNull Nothing menv' "ghc-pkg" [ "register" , "--force" @@ -968,7 +1024,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in realConfigAndBuild cache allDepsMap = withSingleContext runInBase ac ee task (Just allDepsMap) Nothing $ \package cabalfp pkgDir cabal announce console _mlogFile -> do - _neededConfig <- ensureConfig cache pkgDir ee (announce "configure") cabal cabalfp + _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix)) cabal cabalfp if boptsOnlyConfigure eeBuildOpts then return Nothing @@ -979,31 +1035,22 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in markExeNotInstalled (taskLocation task) taskProvides case taskType of - TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp + TTLocal lp -> do + when enableTests $ unsetTestSuccess pkgDir + writeBuildCache pkgDir $ lpNewBuildCache lp TTUpstream _ _ -> return () - () <- announce "build" + () <- announce ("build" <> annSuffix) config <- asks getConfig extraOpts <- extraBuildOptions eeBuildOpts preBuildTime <- modTime <$> liftIO getCurrentTime - cabal (console && configHideTHLoading config) $ - (case taskType of - TTLocal lp -> concat - [ ["build"] - , ["lib:" ++ packageNameString (packageName package) - -- TODO: get this information from target parsing instead, - -- which will allow users to turn off library building if - -- desired - | packageHasLibrary package] - , map (T.unpack . T.append "exe:") $ Set.toList $ - case lpExeComponents lp of - Just exes -> exes - -- Build all executables in the event that no - -- specific list is provided (as happens with - -- extra-deps). - Nothing -> packageExes package - ] - TTUpstream _ _ -> ["build"]) ++ extraOpts + cabal (console && configHideTHLoading config) $ ("build" :) $ (++ extraOpts) $ + case (taskType, taskAllInOne, isFinalBuild) of + (_, True, True) -> fail "Invariant violated: cannot have an all-in-one build that also has a final build step." + (TTLocal lp, False, False) -> primaryComponentOptions lp + (TTLocal lp, False, True) -> finalComponentOptions lp + (TTLocal lp, True, False) -> primaryComponentOptions lp ++ finalComponentOptions lp + (TTUpstream{}, _, _) -> [] checkForUnlistedFiles taskType preBuildTime pkgDir when (doHaddock package) $ do @@ -1024,21 +1071,19 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"] ,sourceFlag]) - withMVar eeInstallLock $ \() -> do + unless isFinalBuild $ withMVar eeInstallLock $ \() -> do announce "copy/register" cabal False ["copy"] when (packageHasLibrary package) $ cabal False ["register"] - let (installedPkgDb, installedDumpPkgsTVar, dumpPkgsTVars) = + let (installedPkgDb, installedDumpPkgsTVar) = case taskLocation task of Snap -> ( bcoSnapDB eeBaseConfigOpts - , eeSnapshotDumpPkgs - , [eeSnapshotDumpPkgs] ) + , eeSnapshotDumpPkgs ) Local -> ( bcoLocalDB eeBaseConfigOpts - , eeLocalDumpPkgs - , [eeSnapshotDumpPkgs, eeLocalDumpPkgs] ) + , eeLocalDumpPkgs ) let ident = PackageIdentifier (packageName package) (packageVersion package) mpkgid <- if packageHasLibrary package then do @@ -1050,18 +1095,6 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow with writeFlagCache? return $ Executable ident - case (doHaddock package && shouldHaddockDeps eeBuildOpts, mpkgid) of - (False, _) -> return () - (True, Executable _) -> return () - (True, Library _ ghcPkgId) -> - withMVar eeInstallLock $ \() -> do - dumpPkgs <- forM dumpPkgsTVars $ \tvar -> liftIO (readTVarIO tvar) - copyDepHaddocks - eeBaseConfigOpts - (reverse (eeGlobalDumpPkgs : dumpPkgs)) - ghcPkgId - Set.empty - case taskLocation task of Snap -> writePrecompiledCache eeBaseConfigOpts taskProvides (configCacheOpts cache) @@ -1107,53 +1140,19 @@ depsPresent installedMap deps = all singleTest :: M env m => (m () -> IO ()) -> TestOpts - -> LocalPackageTB + -> [Text] -> ActionContext -> ExecuteEnv -> Task -> InstalledMap -> m () -singleTest runInBase topts lptb ac ee task installedMap = do - (allDepsMap, cache) <- getConfigCache ee task $ - case taskType task of - TTLocal lp -> concat - [ ["--enable-tests"] - , ["--enable-benchmarks" | depsPresent installedMap $ lpBenchDeps lp] - ] - _ -> [] - withSingleContext runInBase ac ee task (Just allDepsMap) (Just "test") $ \package cabalfp pkgDir cabal announce console mlogFile -> do - neededConfig <- ensureConfig cache pkgDir ee (announce "configure (test)") cabal cabalfp +singleTest runInBase topts testsToRun ac ee task installedMap = do + -- FIXME: Since this doesn't use cabal, we should be able to avoid using a + -- fullblown 'withSingleContext'. + (allDepsMap, _cache) <- getConfigCache ee task installedMap True False + withSingleContext runInBase ac ee task (Just allDepsMap) (Just "test") $ \package _cabalfp pkgDir _cabal announce _console mlogFile -> do config <- asks getConfig - - testBuilt <- checkTestBuilt pkgDir - - let needBuild = neededConfig || - (case taskType task of - TTLocal lp -> - case lpDirtyFiles lp of - Just _ -> True - Nothing -> False - _ -> assert False True) || - not testBuilt - - needHpc = toCoverage topts - - testsToRun = Set.toList $ lptbTests lptb - components = map (T.unpack . T.append "test:") testsToRun - - when needBuild $ do - announce "build (test)" - unsetTestBuilt pkgDir - unsetTestSuccess pkgDir - case taskType task of - TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp - TTUpstream _ _ -> assert False $ return () - extraOpts <- extraBuildOptions (eeBuildOpts ee) - preBuildTime <- modTime <$> liftIO getCurrentTime - cabal (console && configHideTHLoading config) $ - "build" : (components ++ extraOpts) - checkForUnlistedFiles (taskType task) preBuildTime pkgDir - setTestBuilt pkgDir + let needHpc = toCoverage topts toRun <- if toDisableRun topts @@ -1256,50 +1255,19 @@ singleTest runInBase topts lptb ac ee task installedMap = do (fmap fst mlogFile) bs - setTestSuccess pkgDir - singleBench :: M env m => (m () -> IO ()) -> BenchmarkOpts - -> LocalPackageTB -> ActionContext -> ExecuteEnv -> Task -> InstalledMap -> m () -singleBench runInBase beopts _lptb ac ee task installedMap = do - (allDepsMap, cache) <- getConfigCache ee task $ - case taskType task of - TTLocal lp -> concat - [ ["--enable-tests" | depsPresent installedMap $ lpTestDeps lp] - , ["--enable-benchmarks"] - ] - _ -> [] - withSingleContext runInBase ac ee task (Just allDepsMap) (Just "bench") $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do - neededConfig <- ensureConfig cache pkgDir ee (announce "configure (benchmarks)") cabal cabalfp - - benchBuilt <- checkBenchBuilt pkgDir - - let needBuild = neededConfig || - (case taskType task of - TTLocal lp -> - case lpDirtyFiles lp of - Just _ -> True - Nothing -> False - _ -> assert False True) || - not benchBuilt - when needBuild $ do - announce "build (benchmarks)" - unsetBenchBuilt pkgDir - case taskType task of - TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp - TTUpstream _ _ -> assert False $ return () - config <- asks getConfig - extraOpts <- extraBuildOptions (eeBuildOpts ee) - preBuildTime <- modTime <$> liftIO getCurrentTime - cabal (console && configHideTHLoading config) ("build" : extraOpts) - checkForUnlistedFiles (taskType task) preBuildTime pkgDir - setBenchBuilt pkgDir +singleBench runInBase beopts ac ee task installedMap = do + -- FIXME: Since this doesn't use cabal, we should be able to avoid using a + -- fullblown 'withSingleContext'. + (allDepsMap, _cache) <- getConfigCache ee task installedMap False True + withSingleContext runInBase ac ee task (Just allDepsMap) (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _console _mlogFile -> do let args = maybe [] ((:[]) . ("--benchmark-options=" <>)) (beoAdditionalArgs beopts) @@ -1321,10 +1289,11 @@ singleBench runInBase beopts _lptb ac ee task installedMap = do printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => Bool -- ^ exclude TH loading? -> Bool -- ^ convert paths to absolute? + -> Path Abs Dir -- ^ package's root directory -> LogLevel -> Handle -> m () -printBuildOutput excludeTHLoading makeAbsolute level outH = void $ - CB.sourceHandle outH +printBuildOutput excludeTHLoading makeAbsolute pkgDir level outH = void $ + CB.sourceHandle outH $$ CB.lines =$ CL.map stripCarriageReturn =$ CL.filter (not . isTHLoading) @@ -1346,10 +1315,10 @@ printBuildOutput excludeTHLoading makeAbsolute level outH = void $ mabs <- if isValidSuffix y then do - efp <- liftIO $ tryIO $ D.canonicalizePath $ S8.unpack x + efp <- liftIO $ tryIO $ resolveFile pkgDir (S8.unpack x) case efp of Left _ -> return Nothing - Right fp -> return $ Just $ S8.pack fp + Right fp -> return $ Just $ S8.pack (toFilePath fp) else return Nothing case mabs of Nothing -> return bs @@ -1365,7 +1334,7 @@ printBuildOutput excludeTHLoading makeAbsolute level outH = void $ guard $ S.head bs1 == _colon (_, bs2) <- S8.readInt $ S.drop 1 bs1 - guard $ bs2 == ":" + guard $ (bs2 == ":" || bs2 == ": Warning:") -- | Strip @\r@ characters from the byte vector. Used because Windows. stripCarriageReturn :: ByteString -> ByteString @@ -1400,6 +1369,44 @@ extraBuildOptions bopts = do return ["--ghc-options", "-hpcdir " ++ hpcIndexDir ++ ddumpOpts] False -> return ["--ghc-options", ddumpOpts] +-- Library and executable build components. +primaryComponentOptions :: LocalPackage -> [String] +primaryComponentOptions lp = concat + [ ["lib:" ++ packageNameString (packageName (lpPackage lp)) + -- TODO: get this information from target parsing instead, + -- which will allow users to turn off library building if + -- desired + | packageHasLibrary (lpPackage lp)] + , map (T.unpack . T.append "exe:") $ Set.toList $ exesToBuild lp + ] + +exesToBuild :: LocalPackage -> Set Text +exesToBuild lp = packageExes (lpPackage lp) + -- NOTE: Ideally we'd do something like the following code, allowing + -- the user to control which executables get built. However, due to + -- https://github.com/haskell/cabal/issues/2780 we must build all + -- exes... + -- + -- if lpWanted lp + -- then exeComponents (lpComponents lp) + -- -- Build all executables in the event that no + -- -- specific list is provided (as happens with + -- -- extra-deps). + -- else packageExes (lpPackage lp) + +-- Test-suite and benchmark build components. +finalComponentOptions :: LocalPackage -> [String] +finalComponentOptions lp = + map (T.unpack . decodeUtf8 . renderComponent) $ + Set.toList $ + Set.filter (\c -> isCTest c || isCBench c) (lpComponents lp) + +taskComponents :: Task -> Set NamedComponent +taskComponents task = + case taskType task of + TTLocal lp -> lpComponents lp + TTUpstream{} -> Set.empty + -- | Take the given list of package dependencies and the contents of the global -- package database, and construct a set of installed package IDs that: -- diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index e41bca5df9..84518b4ef5 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -8,45 +8,52 @@ -- | Generate haddocks module Stack.Build.Haddock - ( copyDepHaddocks - , generateLocalHaddockIndex + ( generateLocalHaddockIndex , generateDepsHaddockIndex , generateSnapHaddockIndex , shouldHaddockPackage , shouldHaddockDeps ) where -import Control.Exception (tryJust) +import Control.Exception (tryJust, onException) import Control.Monad import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Trans.Resource +import qualified Data.Foldable as F import Data.Function +import qualified Data.HashSet as HS import Data.List import Data.List.Extra (nubOrd) -import Data.Maybe import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Maybe.Extra (mapMaybeM) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T +import Data.Time (UTCTime) import Path +import Path.Extra import Path.IO import Prelude -import Safe (maximumMay) import Stack.Types.Build import Stack.PackageDump import Stack.Types -import System.Directory (getModificationTime, canonicalizePath, - doesDirectoryExist) +import System.Directory (getModificationTime) import qualified System.FilePath as FP import System.IO.Error (isDoesNotExistError) import System.Process.Read -- | Determine whether we should haddock for a package. -shouldHaddockPackage :: BuildOpts -> Set PackageName -> PackageName -> Bool +shouldHaddockPackage :: BuildOpts + -> Set PackageName -- ^ Packages that we want to generate haddocks for + -- in any case (whether or not we are going to generate + -- haddocks for dependencies) + -> PackageName + -> Bool shouldHaddockPackage bopts wanted name = if Set.member name wanted then boptsHaddock bopts @@ -56,94 +63,28 @@ shouldHaddockPackage bopts wanted name = shouldHaddockDeps :: BuildOpts -> Bool shouldHaddockDeps bopts = fromMaybe (boptsHaddock bopts) (boptsHaddockDeps bopts) --- | Copy dependencies' haddocks to documentation directory. This way, relative @../$pkg-$ver@ --- links work and it's easy to upload docs to a web server or otherwise view them in a --- non-local-filesystem context. We copy instead of symlink for two reasons: (1) symlinks aren't --- reliably supported on Windows, and (2) the filesystem containing dependencies' docs may not be --- available where viewing the docs (e.g. if building in a Docker container). -copyDepHaddocks :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m) - => BaseConfigOpts - -> [Map GhcPkgId (DumpPackage () ())] - -> GhcPkgId - -> Set (Path Abs Dir) - -> m () -copyDepHaddocks bco dumpPkgs ghcPkgId extraDestDirs = do - let mdp = lookupDumpPackage ghcPkgId dumpPkgs - case mdp of - Nothing -> return () - Just dp -> - forM_ (dpDepends dp) $ \depDP -> - case dpHaddockHtml dp of - Nothing -> return () - Just pkgHtmlFP -> do - pkgHtmlDir <- parseAbsDir pkgHtmlFP - copyDepWhenNeeded pkgHtmlDir depDP - where - copyDepWhenNeeded pkgHtmlDir depGhcPkgId = do - let mDepDP = lookupDumpPackage depGhcPkgId dumpPkgs - case mDepDP of - Nothing -> return () - Just depDP -> - case dpHaddockHtml depDP of - Nothing -> return () - Just depOrigFP0 -> do - let extraDestDirs' = - -- Parent test ensures we don't try to copy docs to global locations - if bcoSnapInstallRoot bco `isParentOf` pkgHtmlDir || - bcoLocalInstallRoot bco `isParentOf` pkgHtmlDir - then Set.insert (parent pkgHtmlDir) extraDestDirs - else extraDestDirs - depOrigFP <- liftIO $ do - exists <- doesDirectoryExist depOrigFP0 - if exists - then canonicalizePath depOrigFP0 - else return depOrigFP0 - depOrigDir <- parseAbsDir depOrigFP - copyWhenNeeded extraDestDirs' (dpPackageIdent depDP) (dpGhcPkgId depDP) depOrigDir - copyWhenNeeded destDirs depId depGhcPkgId depOrigDir = do - depRelDir <- parseRelDir (packageIdentifierString depId) - copied <- forM (Set.toList destDirs) $ \destDir -> do - let depCopyDir = destDir depRelDir - if depCopyDir == depOrigDir - then return False - else do - needCopy <- getNeedCopy depOrigDir depCopyDir - when needCopy $ doCopy depOrigDir depCopyDir - return needCopy - when (or copied) $ - copyDepHaddocks bco dumpPkgs depGhcPkgId destDirs - getNeedCopy depOrigDir depCopyDir = do - let depOrigIndex = haddockIndexFile depOrigDir - depCopyIndex = haddockIndexFile depCopyDir - depOrigExists <- fileExists depOrigIndex - depCopyExists <- fileExists depCopyIndex - case (depOrigExists, depCopyExists) of - (False, _) -> return False - (True, False) -> return True - (True, True) -> do - copyMod <- liftIO $ getModificationTime (toFilePath depCopyIndex) - origMod <- liftIO $ getModificationTime (toFilePath depOrigIndex) - return (copyMod <= origMod) - doCopy depOrigDir depCopyDir = do - removeTreeIfExists depCopyDir - createTree depCopyDir - copyDirectoryRecursive depOrigDir depCopyDir - -- | Generate Haddock index and contents for local packages. generateLocalHaddockIndex :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m) - => EnvOverride -> WhichCompiler -> BaseConfigOpts -> [LocalPackage] -> m () -generateLocalHaddockIndex envOverride wc bco locals = do - let packageIDs = - map + => EnvOverride + -> WhichCompiler + -> BaseConfigOpts + -> Map GhcPkgId (DumpPackage () ()) -- ^ Local package dump + -> [LocalPackage] + -> m () +generateLocalHaddockIndex envOverride wc bco localDumpPkgs locals = do + let dumpPackages = + mapMaybe (\LocalPackage{lpPackage = Package{..}} -> - PackageIdentifier packageName packageVersion) + F.find + (\dp -> dpPackageIdent dp == PackageIdentifier packageName packageVersion) + localDumpPkgs) locals generateHaddockIndex "local packages" envOverride wc - packageIDs + dumpPackages "." (localDocDir bco) @@ -153,43 +94,42 @@ generateDepsHaddockIndex => EnvOverride -> WhichCompiler -> BaseConfigOpts - -> Map GhcPkgId (DumpPackage () ()) - -> Map GhcPkgId (DumpPackage () ()) - -> Map GhcPkgId (DumpPackage () ()) + -> Map GhcPkgId (DumpPackage () ()) -- ^ Global dump information + -> Map GhcPkgId (DumpPackage () ()) -- ^ Snapshot dump information + -> Map GhcPkgId (DumpPackage () ()) -- ^ Local dump information -> [LocalPackage] -> m () generateDepsHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do - let depGhcPkgIds = - map - (\LocalPackage{lpPackage = Package{..}} -> - let pkgId = PackageIdentifier packageName packageVersion - in case find - (\dp -> - dpPackageIdent dp == pkgId) - (Map.elems localDumpPkgs) of - Nothing -> Set.empty - Just dp -> findTransitiveDepends (dpGhcPkgId dp)) - locals - depDumpPkgs = - map - (\ghcPkgId -> - lookupDumpPackage ghcPkgId allDumpPkgs) - (Set.toList $ Set.unions depGhcPkgIds) + let deps = (mapMaybe (`lookupDumpPackage` allDumpPkgs) . nubOrd . findTransitiveDepends . mapMaybe getGhcPkgId) locals + depDocDir = localDocDir bco $(mkRelDir "all") generateHaddockIndex "local packages and dependencies" envOverride wc - (nubOrd $ map dpPackageIdent $ catMaybes depDumpPkgs) + deps ".." - (localDocDir bco $(mkRelDir "all")) + depDocDir where - findTransitiveDepends ghcPkgId = - case lookupDumpPackage ghcPkgId allDumpPkgs of - Nothing -> Set.singleton ghcPkgId - Just pkgDP -> - Set.unions - (Set.singleton ghcPkgId : - map findTransitiveDepends (dpDepends pkgDP)) + getGhcPkgId :: LocalPackage -> Maybe GhcPkgId + getGhcPkgId LocalPackage{lpPackage = Package{..}} = + let pkgId = PackageIdentifier packageName packageVersion + mdpPkg = F.find (\dp -> dpPackageIdent dp == pkgId) localDumpPkgs + in fmap dpGhcPkgId mdpPkg + findTransitiveDepends :: [GhcPkgId] -> [GhcPkgId] + findTransitiveDepends = (`go` HS.empty) . HS.fromList + where + go todo checked = + case HS.toList todo of + [] -> HS.toList checked + (ghcPkgId:_) -> + let deps = + case lookupDumpPackage ghcPkgId allDumpPkgs of + Nothing -> HS.empty + Just pkgDP -> HS.fromList (dpDepends pkgDP) + deps' = deps `HS.difference` checked + todo' = HS.delete ghcPkgId (deps' `HS.union` todo) + checked' = HS.insert ghcPkgId checked + in go todo' checked' allDumpPkgs = [localDumpPkgs, snapshotDumpPkgs, globalDumpPkgs] -- | Generate Haddock index and contents for all snapshot packages. @@ -198,18 +138,15 @@ generateSnapHaddockIndex => EnvOverride -> WhichCompiler -> BaseConfigOpts - -> Map GhcPkgId (DumpPackage () ()) - -> Map GhcPkgId (DumpPackage () ()) + -> Map GhcPkgId (DumpPackage () ()) -- ^ Global package dump + -> Map GhcPkgId (DumpPackage () ()) -- ^ Snapshot package dump -> m () generateSnapHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs = generateHaddockIndex "snapshot packages" envOverride wc - (nubOrd $ - map - dpPackageIdent - (Map.elems globalDumpPkgs ++ Map.elems snapshotDumpPkgs)) + (Map.elems snapshotDumpPkgs ++ Map.elems globalDumpPkgs) "." (snapDocDir bco) @@ -219,63 +156,89 @@ generateHaddockIndex => Text -> EnvOverride -> WhichCompiler - -> [PackageIdentifier] + -> [DumpPackage () ()] -> FilePath -> Path Abs Dir -> m () -generateHaddockIndex descr envOverride wc packageIDs docRelDir destDir = do +generateHaddockIndex descr envOverride wc dumpPackages docRelFP destDir = do createTree destDir - interfaceOpts <- liftIO $ fmap catMaybes (mapM toInterfaceOpt packageIDs) - case maximumMay (map snd interfaceOpts) of - Nothing -> return () - Just maxInterfaceModTime -> do - eindexModTime <- - liftIO $ - tryJust (guard . isDoesNotExistError) $ - getModificationTime (toFilePath (haddockIndexFile destDir)) - let needUpdate = - case eindexModTime of - Left _ -> True - Right indexModTime -> - indexModTime < maxInterfaceModTime - when - needUpdate $ - do $logInfo - (T.concat ["Updating Haddock index for ", descr, " in\n", - T.pack (toFilePath (haddockIndexFile destDir))]) - readProcessNull - (Just destDir) - envOverride - (haddockExeName wc) - (["--gen-contents", "--gen-index"] ++ concatMap fst interfaceOpts) + interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages + unless (null interfaceOpts) $ do + let destIndexFile = toFilePath (haddockIndexFile destDir) + eindexModTime <- liftIO (tryGetModificationTime destIndexFile) + let needUpdate = + case eindexModTime of + Left _ -> True + Right indexModTime -> + or [mt > indexModTime | (_,mt,_,_) <- interfaceOpts] + when needUpdate $ do + $logInfo + (T.concat ["Updating Haddock index for ", descr, " in\n", + T.pack destIndexFile]) + liftIO (mapM_ copyPkgDocs interfaceOpts) + readProcessNull + (Just destDir) + envOverride + (haddockExeName wc) + (["--gen-contents", "--gen-index"] ++ [x | (xs,_,_,_) <- interfaceOpts, x <- xs]) where - toInterfaceOpt pid@(PackageIdentifier name _) = do - let interfaceRelFile = - docRelDir FP. packageIdentifierString pid FP. - packageNameString name FP.<.> - "haddock" - interfaceAbsFile = toFilePath destDir FP. interfaceRelFile - einterfaceModTime <- - tryJust (guard . isDoesNotExistError) $ - getModificationTime interfaceAbsFile - return $ - case einterfaceModTime of - Left _ -> Nothing - Right interfaceModTime -> - Just - ( [ "-i" - , concat - [ docRelDir FP. packageIdentifierString pid - , "," - , interfaceRelFile]] - , interfaceModTime) + toInterfaceOpt :: DumpPackage a b -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File)) + toInterfaceOpt DumpPackage {..} = do + case dpHaddockInterfaces of + [] -> return Nothing + srcInterfaceFP:_ -> do + srcInterfaceAbsFile <- parseCollapsedAbsFile srcInterfaceFP + let (PackageIdentifier name _) = dpPackageIdent + destInterfaceRelFP = + docRelFP FP. + packageIdentifierString dpPackageIdent FP. + (packageNameString name FP.<.> "haddock") + destInterfaceAbsFile <- parseCollapsedAbsFile (toFilePath destDir FP. destInterfaceRelFP) + esrcInterfaceModTime <- tryGetModificationTime (toFilePath srcInterfaceAbsFile) + return $ + case esrcInterfaceModTime of + Left _ -> Nothing + Right srcInterfaceModTime -> + Just + ( [ "-i" + , concat + [ docRelFP FP. packageIdentifierString dpPackageIdent + , "," + , destInterfaceRelFP ]] + , srcInterfaceModTime + , srcInterfaceAbsFile + , destInterfaceAbsFile ) + tryGetModificationTime :: FilePath -> IO (Either () UTCTime) + tryGetModificationTime = tryJust (guard . isDoesNotExistError) . getModificationTime + copyPkgDocs :: (a, UTCTime, Path Abs File, Path Abs File) -> IO () + copyPkgDocs (_,srcInterfaceModTime,srcInterfaceAbsFile,destInterfaceAbsFile) = do + -- Copy dependencies' haddocks to documentation directory. This way, relative @../$pkg-$ver@ + -- links work and it's easy to upload docs to a web server or otherwise view them in a + -- non-local-filesystem context. We copy instead of symlink for two reasons: (1) symlinks + -- aren't reliably supported on Windows, and (2) the filesystem containing dependencies' + -- docs may not be available where viewing the docs (e.g. if building in a Docker + -- container). + edestInterfaceModTime <- tryGetModificationTime (toFilePath destInterfaceAbsFile) + case edestInterfaceModTime of + Left _ -> doCopy + Right destInterfaceModTime + | destInterfaceModTime < srcInterfaceModTime -> doCopy + | otherwise -> return () + where + doCopy = do + removeTreeIfExists destHtmlAbsDir + createTree destHtmlAbsDir + onException + (copyDirectoryRecursive (parent srcInterfaceAbsFile) destHtmlAbsDir) + (removeTreeIfExists destHtmlAbsDir) + destHtmlAbsDir = parent destInterfaceAbsFile -- | Find first DumpPackage matching the GhcPkgId lookupDumpPackage :: GhcPkgId -> [Map GhcPkgId (DumpPackage () ())] -> Maybe (DumpPackage () ()) lookupDumpPackage ghcPkgId dumpPkgs = - listToMaybe $ catMaybes $ map (Map.lookup ghcPkgId) dumpPkgs + listToMaybe $ mapMaybe (Map.lookup ghcPkgId) dumpPkgs -- | Path of haddock index file. haddockIndexFile :: Path Abs Dir -> Path Abs File diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index 8a71d6494a..d9cd5571d0 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -27,6 +27,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Maybe.Extra (mapMaybeM) import Data.Monoid import qualified Data.Text as T import Network.HTTP.Client.Conduit (HasHttpManager) @@ -77,9 +78,9 @@ getInstalled menv opts sourceMap = do (installedLibs0, globalDumpPkgs) <- loadDatabase' Nothing [] (installedLibs1, _extraInstalled) <- - (foldM (\lhs' pkgdb -> do - lhs'' <- loadDatabase' (Just (ExtraGlobal, pkgdb)) (fst lhs') - return lhs'') (installedLibs0, globalDumpPkgs) extraDBPaths) + (foldM (\lhs' pkgdb -> + loadDatabase' (Just (ExtraGlobal, pkgdb)) (fst lhs') + ) (installedLibs0, globalDumpPkgs) extraDBPaths) (installedLibs2, snapshotDumpPkgs) <- loadDatabase' (Just (InstalledTo Snap, snapDBPath)) installedLibs1 (installedLibs3, localDumpPkgs) <- @@ -136,7 +137,7 @@ loadDatabase menv opts mcache sourceMap mdb lhs0 = do (lhs1', dps) <- ghcPkgDump menv wc (fmap snd (maybeToList mdb)) $ conduitDumpPackage =$ sink let ghcjsHack = wc == Ghcjs && isNothing mdb - lhs1 <- liftM catMaybes $ mapM (processLoadResult mdb ghcjsHack) lhs1' + lhs1 <- mapMaybeM (processLoadResult mdb ghcjsHack) lhs1' let lhs = pruneDeps id lhId @@ -198,7 +199,7 @@ processLoadResult mdb _ (reason, lh) = do NeedsHaddock -> " it needing haddocks." UnknownPkg -> " it being unknown to the resolver / extra-deps." WrongLocation mloc loc -> " wrong location: " <> T.pack (show (mloc, loc)) - WrongVersion actual wanted -> T.concat $ + WrongVersion actual wanted -> T.concat [ " wanting version " , versionText wanted , " instead of " diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 7fcbc88b74..9919cfbf65 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -60,7 +60,6 @@ import Stack.BuildPlan (loadMiniBuildPlan, shadowMiniBuildPlan, parseCustomMiniBuildPlan) import Stack.Constants (wiredInPackages) import Stack.Package -import Stack.PackageIndex import Stack.Types import System.Directory @@ -80,9 +79,10 @@ loadSourceMap needTargets bopts = do bconfig <- asks getBuildConfig rawLocals <- getLocalPackageViews (mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOpts needTargets bopts - menv <- getMinimalEnvOverride - caches <- getPackageCaches menv - let latestVersion = Map.fromListWith max $ map toTuple $ Map.keys caches + let latestVersion = + Map.fromListWith max $ + map toTuple $ + Map.keys (bcPackageCaches bconfig) -- Extend extra-deps to encompass targets requested on the command line -- that are not in the snapshot. @@ -115,7 +115,7 @@ loadSourceMap needTargets bopts = do -- the snapshot extraDeps2 = Map.union (Map.map (\v -> (v, Map.empty)) extraDeps0) - (Map.map (\mpi -> (mpiVersion mpi, mpiFlags mpi)) extraDeps1) + (Map.map (mpiVersion &&& mpiFlags) extraDeps1) -- Overwrite any flag settings with those from the config file extraDeps3 = Map.mapWithKey @@ -230,7 +230,7 @@ getLocalPackageViews = do (warnings,gpkg) <- readPackageUnresolved cabalfp mapM_ (printCabalFileWarning cabalfp) warnings let cabalID = package $ packageDescription gpkg - name = fromCabalPackageName $ pkgName $ cabalID + name = fromCabalPackageName $ pkgName cabalID checkCabalFileName name cabalfp let lpv = LocalPackageView { lpvVersion = fromCabalVersion $ pkgVersion cabalID @@ -329,11 +329,7 @@ loadLocalPackage bopts targets (name, (lpv, gpkg)) = do btpkg | Set.null tests && Set.null benches = Nothing - | otherwise = Just $ LocalPackageTB - { lptbPackage = resolvePackage btconfig gpkg - , lptbTests = tests - , lptbBenches = benches - } + | otherwise = Just (resolvePackage btconfig gpkg) testpkg = resolvePackage testconfig gpkg benchpkg = resolvePackage benchconfig gpkg mbuildCache <- tryGetBuildCache $ lpvRoot lpv @@ -348,25 +344,20 @@ loadLocalPackage bopts targets (name, (lpv, gpkg)) = do return LocalPackage { lpPackage = pkg - , lpTestDeps = packageDeps $ testpkg - , lpBenchDeps = packageDeps $ benchpkg - , lpExeComponents = - case mtarget of - Nothing -> Nothing - Just _ -> Just exes + , lpTestDeps = packageDeps testpkg + , lpBenchDeps = packageDeps benchpkg , lpTestBench = btpkg , lpFiles = files , lpDirtyFiles = if not (Set.null dirtyFiles) || boptsForceDirty bopts then let tryStripPrefix y = - case stripPrefix (toFilePath $ lpvRoot lpv) y of - Nothing -> y - Just z -> z + fromMaybe y (stripPrefix (toFilePath $ lpvRoot lpv) y) in Just $ Set.map tryStripPrefix dirtyFiles else Nothing , lpNewBuildCache = newBuildCache , lpCabalFile = lpvCabalFP lpv , lpDir = lpvRoot lpv + , lpWanted = isJust mtarget , lpComponents = Set.unions [ Set.map CExe exes , Set.map CTest tests @@ -425,9 +416,9 @@ localFlags :: (Map (Maybe PackageName) (Map FlagName Bool)) -> PackageName -> Map FlagName Bool localFlags boptsflags bconfig name = Map.unions - [ fromMaybe Map.empty $ Map.lookup (Just name) $ boptsflags - , fromMaybe Map.empty $ Map.lookup Nothing $ boptsflags - , fromMaybe Map.empty $ Map.lookup name $ bcFlags bconfig + [ 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 @@ -468,7 +459,7 @@ checkBuildCache :: MonadIO m -> [FilePath] -- ^ files in package -> m (Set FilePath, Map FilePath FileCacheInfo) checkBuildCache oldCache files = liftIO $ do - (dirtyFiles, m) <- fmap mconcat $ mapM go files + (dirtyFiles, m) <- mconcat <$> mapM go files return (dirtyFiles, m) where go fp = do diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 4235c80f62..d23fbda09a 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -145,7 +145,7 @@ resolveIdents :: Map PackageName Version -- ^ snapshot -> Either Text ((RawInput, RawTarget 'NoIdents), Map PackageName Version) resolveIdents _ _ _ (ri, RTPackageComponent x y) = Right ((ri, RTPackageComponent x y), Map.empty) resolveIdents _ _ _ (ri, RTComponent x) = Right ((ri, RTComponent x), Map.empty) -resolveIdents _ _ _ (ri, RTPackage x) = Right $ ((ri, RTPackage x), Map.empty) +resolveIdents _ _ _ (ri, RTPackage x) = Right ((ri, RTPackage x), Map.empty) resolveIdents snap extras locals (ri, RTPackageIdentifier (PackageIdentifier name version)) = case mfound of Just (foundPlace, foundVersion) | foundVersion /= version -> Left $ T.pack $ concat diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index f194f77bea..23e8e29db6 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -6,7 +6,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} - -- | Resolving a build plan for a set of packages in a given Stackage -- snapshot. @@ -76,9 +75,7 @@ import Path.IO import Prelude -- Fix AMP warning import Stack.Constants import Stack.Fetch -import Stack.GhcPkg import Stack.Package -import Stack.PackageIndex import Stack.Types import Stack.Types.StackT import System.Directory (canonicalizePath) @@ -177,21 +174,22 @@ instance Show BuildPlanException where -- -- This may fail if a target package is not present in the @BuildPlan@. resolveBuildPlan :: (MonadThrow m, MonadIO m, MonadReader env m, HasBuildConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m,MonadCatch m) - => EnvOverride - -> MiniBuildPlan + => MiniBuildPlan -> (PackageName -> Bool) -- ^ is it shadowed by a local package? -> Map PackageName (Set PackageName) -- ^ required packages, and users of it -> m ( Map PackageName (Version, Map FlagName Bool) , Map PackageName (Set PackageName) ) -resolveBuildPlan menv mbp isShadowed packages +resolveBuildPlan mbp isShadowed packages | Map.null (rsUnknown rs) && Map.null (rsShadowed rs) = return (rsToInstall rs, rsUsedBy rs) | otherwise = do - cache <- getPackageCaches menv - let maxVer = Map.fromListWith max $ map toTuple $ Map.keys cache + bconfig <- asks getBuildConfig + let maxVer = + Map.fromListWith max $ + map toTuple $ + Map.keys (bcPackageCaches bconfig) unknown = flip Map.mapWithKey (rsUnknown rs) $ \ident x -> (Map.lookup ident maxVer, x) - bconfig <- asks getBuildConfig throwM $ UnknownPackages (bcStackYaml bconfig) unknown @@ -434,8 +432,7 @@ loadMiniBuildPlan -> m MiniBuildPlan loadMiniBuildPlan name = do path <- configMiniBuildPlanCache name - let fp = toFilePath path - taggedDecodeOrLoad fp $ liftM buildPlanFixes $ do + taggedDecodeOrLoad path $ liftM buildPlanFixes $ do bp <- loadBuildPlan name toMiniBuildPlan (siCompilerVersion $ bpSystemInfo bp) @@ -693,7 +690,7 @@ parseCustomMiniBuildPlan stackYamlFP url0 = do customPlanDir <- getCustomPlanDir let binaryFP = customPlanDir $(mkRelDir "bin") binaryFilename - taggedDecodeOrLoad (toFilePath binaryFP) $ do + taggedDecodeOrLoad binaryFP $ do cs <- either throwM return $ decodeEither' yamlBS let addFlags :: PackageIdentifier -> (PackageName, (Version, Map FlagName Bool)) addFlags (PackageIdentifier name ver) = diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 28de0964c5..ef4b4434a0 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -70,6 +70,7 @@ import Stack.Constants import Stack.Config.Docker import qualified Stack.Image as Image import Stack.Init +import Stack.PackageIndex import Stack.Types import Stack.Types.Internal import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing, canonicalizePath) @@ -86,10 +87,7 @@ getLatestResolver = do let mlts = do (x,y) <- listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots))) return (LTS x y) - snap = - case mlts of - Nothing -> Nightly (snapshotsNightly snapshots) - Just lts -> lts + snap = fromMaybe (Nightly (snapshotsNightly snapshots)) mlts return (ResolverSnapshot snap) -- Interprets ConfigMonoid options. @@ -171,7 +169,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir return $ localDir $(mkRelDir "bin") Just userPath -> - (liftIO $ canonicalizePath userPath >>= parseAbsDir) + liftIO (canonicalizePath userPath >>= parseAbsDir) `catches` [Handler (\(_ :: IOException) -> throwM $ NoSuchDirectory userPath) ,Handler (\(_ :: PathParseException) -> throwM $ NoSuchDirectory userPath) @@ -250,7 +248,7 @@ loadMiniConfig :: (MonadIO m, HasHttpManager a, MonadReader a m, MonadBaseControl IO m, MonadCatch m, MonadLogger m) => Config -> m MiniConfig loadMiniConfig config = do - menv <- liftIO $ (configEnvOverride config) minimalEnvSettings + menv <- liftIO $ configEnvOverride config minimalEnvSettings manager <- getHttpManager <$> ask ghcVariant <- case configGHCVariant0 config of @@ -283,7 +281,7 @@ loadConfig configArgs mstackYaml = do Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config) (throwM (BadStackVersionException (configRequireStackVersion config))) - return $ LoadConfig + return LoadConfig { lcConfig = config , lcLoadBuildConfig = loadBuildConfig mproject config , lcProjectRoot = fmap (\(_, fp, _) -> parent fp) mproject @@ -362,7 +360,7 @@ loadBuildConfig mproject config mresolver mcompiler = do resolver <- case mresolver of Nothing -> return $ projectResolver project' - Just aresolver -> do + Just aresolver -> runReaderT (makeConcreteResolver aresolver) miniConfig let project = project' { projectResolver = resolver @@ -383,6 +381,8 @@ loadBuildConfig mproject config mresolver mcompiler = do extraPackageDBs <- mapM parseRelAsAbsDir (projectExtraPackageDBs project) + packageCaches <- runReaderT (getMinimalEnvOverride >>= getPackageCaches) miniConfig + return BuildConfig { bcConfig = config , bcResolver = projectResolver project @@ -394,6 +394,7 @@ loadBuildConfig mproject config mresolver mcompiler = do , bcFlags = projectFlags project , bcImplicitGlobal = isNothing mproject , bcGHCVariant = getGHCVariant miniConfig + , bcPackageCaches = packageCaches } -- | Resolve a PackageEntry into a list of paths, downloading and cloning as diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs index 53d40dabf4..6459a9e5cd 100644 --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -10,6 +10,7 @@ import Data.List (find) import Data.Maybe import qualified Data.Text as T import Data.Typeable (Typeable) +import Distribution.Version (simplifyVersionRange) import Path import Stack.Types @@ -55,6 +56,7 @@ dockerOptsFromMonoid mproject stackRoot DockerOptsMonoid{..} = do dockerMount = dockerMonoidMount dockerEnv = dockerMonoidEnv dockerSetUser = dockerMonoidSetUser + dockerRequireDockerVersion = simplifyVersionRange dockerMonoidRequireDockerVersion dockerDatabasePath <- case dockerMonoidDatabasePath of Nothing -> return $ stackRoot $(mkRelFile "docker.db") diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index 7be5ef1683..0459e9abbc 100644 --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -124,7 +124,7 @@ objectInterfaceDir bconfig = bcWorkDir bconfig $(mkRelDir "odir/") buildCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env) => Path Abs Dir -- ^ Package directory. -> m (Path Abs File) -buildCacheFile dir = do +buildCacheFile dir = liftM ( $(mkRelFile "stack-build-cache")) (distDirFromDir dir) @@ -160,7 +160,7 @@ benchBuiltFile dir = configCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env) => Path Abs Dir -- ^ Package directory. -> m (Path Abs File) -configCacheFile dir = do +configCacheFile dir = liftM ( $(mkRelFile "stack-config-cache")) (distDirFromDir dir) @@ -169,7 +169,7 @@ configCacheFile dir = do configCabalMod :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env) => Path Abs Dir -- ^ Package directory. -> m (Path Abs File) -configCabalMod dir = do +configCabalMod dir = liftM ( $(mkRelFile "stack-cabal-mod")) (distDirFromDir dir) @@ -271,7 +271,7 @@ wiredInPackages :: HashSet PackageName wiredInPackages = maybe (error "Parse error in wiredInPackages") HashSet.fromList mparsed where - mparsed = sequence $ map parsePackageName + mparsed = mapM parsePackageName [ "ghc-prim" , "integer-gmp" , "integer-simple" @@ -290,7 +290,7 @@ ghcjsBootPackages :: HashSet PackageName ghcjsBootPackages = maybe (error "Parse error in ghcjsBootPackages") HashSet.fromList mparsed where - mparsed = sequence $ map parsePackageName + mparsed = mapM parsePackageName -- stage1a [ "array" , "base" diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs index 15dc03e2d2..3d67de3b6d 100644 --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -17,7 +17,7 @@ module Stack.Coverage import Control.Applicative import Control.Exception.Lifted -import Control.Monad (liftM, when, void) +import Control.Monad (liftM, when, unless, void) import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class import Control.Monad.Logger @@ -29,6 +29,7 @@ import Data.Function import Data.List import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Maybe.Extra (mapMaybeM) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T @@ -268,7 +269,7 @@ generateHpcUnifiedReport = do return (filter ((".tix" `isSuffixOf`) . toFilePath) files) let reportDir = outputDir $(mkRelDir "combined/all") if length tixFiles < 2 - then $logInfo $ T.concat $ + then $logInfo $ T.concat [ if null tixFiles then "No tix files" else "Only one tix file" , " found in " , T.pack (toFilePath outputDir) @@ -279,10 +280,9 @@ generateHpcUnifiedReport = do generateUnionReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) => Text -> Path Abs Dir -> [Path Abs File] -> m () generateUnionReport report reportDir tixFiles = do - tixes <- mapM (liftM (fmap removeExeModules) . readTixOrLog) tixFiles + (errs, tix) <- fmap (unionTixes . map removeExeModules) (mapMaybeM readTixOrLog tixFiles) $logDebug $ "Using the following tix files: " <> T.pack (show tixFiles) - let (errs, tix) = unionTixes (catMaybes tixes) - when (not (null errs)) $ $logWarn $ T.concat $ + unless (null errs) $ $logWarn $ T.concat $ "The following modules are left out of the " : report : " due to version mismatches: " : intersperse ", " (map T.pack errs) tixDest <- liftM (reportDir ) $ parseRelFile (dirnameString reportDir ++ ".tix") @@ -364,14 +364,14 @@ generateHpcMarkupIndex = do rows ++ [""]) ++ [""] - when (not (null rows)) $ + unless (null rows) $ $logInfo $ "\nAn index of the generated HTML coverage reports is available at " <> T.pack (toFilePath outputFile) generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Text -> m () generateHpcErrorReport dir err = do createTree dir - liftIO $ T.writeFile (toFilePath (dir $(mkRelFile "hpc_index.html"))) $ T.concat $ + liftIO $ T.writeFile (toFilePath (dir $(mkRelFile "hpc_index.html"))) $ T.concat [ "" , "

HPC Report Generation Error

" , "

" diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 1e88ce0597..4273959a58 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -33,11 +33,12 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char (isSpace,toUpper,isAscii,isDigit) import Data.Conduit.List (sinkNull) -import Data.List (dropWhileEnd,intercalate,intersperse,isPrefixOf,isInfixOf,foldl',sortBy) +import Data.List (dropWhileEnd,intercalate,isPrefixOf,isInfixOf,foldl') import Data.List.Extra (trim) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Ord (Down(..)) import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import Data.Text (Text) import qualified Data.Text as T @@ -47,6 +48,7 @@ import Data.Typeable (Typeable) import Data.Version (showVersion) import Distribution.System (Platform (Platform), Arch (X86_64), OS (Linux)) import Distribution.Text (display) +import GHC.Exts (sortWith) import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.Extra (toFilePathNoTrailingSep) @@ -126,10 +128,8 @@ reexecWithOptionalContainer mprojectRoot = exeTimestamp return (exePath, exeTimestamp, isKnown) case misCompatible of - Just True -> do - return (cmdArgs args exePath) - Just False -> do - exeDownload args + Just True -> return (cmdArgs args exePath) + Just False -> exeDownload args Nothing -> do e <- try $ @@ -160,15 +160,13 @@ reexecWithOptionalContainer mprojectRoot = if compatible then return (cmdArgs args exePath) else exeDownload args - Nothing - | otherwise -> do - exeDownload args + Nothing -> exeDownload args exeDownload args = fmap (cmdArgs args . toFilePath) (ensureDockerStackExe dockerContainerPlatform) cmdArgs args exePath = - let mountPath = concat ["/opt/host/bin/", takeBaseName exePath] + let mountPath = "/opt/host/bin/" ++ takeBaseName exePath in (mountPath, args, [], [Mount exePath mountPath]) -- | If Docker is enabled, re-runs the OS command returned by the second argument in a @@ -235,7 +233,7 @@ runContainerAndExit getCmdArgs do config <- asks getConfig let docker = configDocker config envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride + checkDockerVersion envOverride docker (dockerHost,dockerCertPath,bamboo,jenkins) <- liftIO ((,,,) <$> lookupEnv "DOCKER_HOST" <*> lookupEnv "DOCKER_CERT_PATH" @@ -295,8 +293,8 @@ runContainerAndExit getCmdArgs (toFilePath projectRoot) mapM_ createTree - (concat [[sandboxHomeDir, sandboxSandboxDir, stackRoot] ++ - sandboxSubdirs])) + ([sandboxHomeDir, sandboxSandboxDir, stackRoot] ++ + sandboxSubdirs)) containerID <- (trim . decodeUtf8) <$> readDockerProcess envOverride (concat @@ -330,8 +328,8 @@ runContainerAndExit getCmdArgs before #ifndef WINDOWS runInBase <- liftBaseWith $ \run -> return (void . run) - oldHandlers <- forM (concat [[(sigINT,sigTERM) | not keepStdinOpen] - ,[(sigTERM,sigTERM)]]) $ \(sigIn,sigOut) -> do + oldHandlers <- forM ([(sigINT,sigTERM) | not keepStdinOpen] ++ + [(sigTERM,sigTERM)]) $ \(sigIn,sigOut) -> do let sigHandler = runInBase (readProcessNull Nothing envOverride "docker" ["kill","--signal=" ++ show sigOut,containerID]) oldHandler <- liftIO $ installHandler sigIn (Catch sigHandler) Nothing @@ -370,8 +368,9 @@ cleanup :: M env m => CleanupOpts -> m () cleanup opts = do config <- asks getConfig + let docker = configDocker config envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride + checkDockerVersion envOverride docker let runDocker = readDockerProcess envOverride imagesOut <- runDocker ["images","--no-trunc","-f","dangling=false"] danglingImagesOut <- runDocker ["images","--no-trunc","-f","dangling=true"] @@ -433,7 +432,7 @@ cleanup opts = | otherwise -> throwM (InvalidCleanupCommandException line) e <- try (readDockerProcess envOverride args) case e of - Left (ReadProcessException _ _ _ _) -> + Left (ReadProcessException{}) -> $logError (concatT ["Could not remove: '",v,"'"]) Left e' -> throwM e' Right _ -> return () @@ -513,17 +512,17 @@ cleanup opts = case accessor opts of Just days -> buildStrLn ("# - " ++ description ++ " at least " ++ showDays days ++ ".") Nothing -> return () - sortCreated l = - reverse (sortBy (\(_,_,a) (_,_,b) -> compare a b) - (catMaybes (map (\(h,r) -> fmap (\ii -> (h,r,iiCreated ii)) - (Map.lookup h inspectMap)) - l))) + sortCreated = + sortWith (\(_,_,x) -> Down x) . + (mapMaybe (\(h,r) -> + case Map.lookup h inspectMap of + Nothing -> Nothing + Just ii -> Just (h,r,iiCreated ii))) buildSection sectionHead items itemBuilder = do let (anyWrote,b) = runWriter (forM items itemBuilder) - if or anyWrote - then do buildSectionHead sectionHead - tell b - else return () + when (or anyWrote) $ + do buildSectionHead sectionHead + tell b buildKnownImage (imageHash,lastUsedProjects) = case Map.lookup imageHash imageRepos of Just repos@(_:_) -> @@ -545,7 +544,7 @@ cleanup opts = buildInspect hash return True buildContainer removeAge (hash,(image,name),created) = - do let disp = (name ++ " (image: " ++ image ++ ")") + do let disp = name ++ " (image: " ++ image ++ ")" buildTime containerStr removeAge created disp buildInspect hash return True @@ -614,7 +613,7 @@ inspects envOverride images = case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of Left msg -> throwM (InvalidInspectOutputException msg) Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results)) - Left (ReadProcessException _ _ _ _) -> return Map.empty + Left (ReadProcessException{}) -> return Map.empty Left e -> throwM e -- | Pull latest version of configured Docker image from registry. @@ -623,7 +622,7 @@ pull = do config <- asks getConfig let docker = configDocker config envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride + checkDockerVersion envOverride docker pullImage envOverride docker (dockerImage docker) -- | Pull Docker image from registry. @@ -650,8 +649,8 @@ pullImage envOverride docker image = -- | Check docker version (throws exception if incorrect) checkDockerVersion :: (MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => EnvOverride -> m () -checkDockerVersion envOverride = + => EnvOverride -> DockerOpts -> m () +checkDockerVersion envOverride docker = do dockerExists <- doesExecutableExist envOverride "docker" unless dockerExists (throwM DockerNotInstalledException) dockerVersionOut <- readDockerProcess envOverride ["--version"] @@ -663,6 +662,8 @@ checkDockerVersion envOverride = throwM (DockerTooOldException minimumDockerVersion v') | v' `elem` prohibitedDockerVersions -> throwM (DockerVersionProhibitedException prohibitedDockerVersions v') + | not (v' `withinRange` dockerRequireDockerVersion docker) -> + throwM (BadDockerVersionException (dockerRequireDockerVersion docker) v') | otherwise -> return () _ -> throwM InvalidVersionOutputException @@ -703,8 +704,7 @@ removeDirectoryContents path excludeDirs excludeFiles = readDockerProcess :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> [String] -> m BS.ByteString -readDockerProcess envOverride args = - readProcessStdout Nothing envOverride "docker" args +readDockerProcess envOverride = readProcessStdout Nothing envOverride "docker" -- | Subdirectories of the home directory to sandbox between GHC/Stackage versions. sandboxedHomeSubdirectories :: [Path Rel Dir] @@ -719,7 +719,7 @@ homeDirName = $(mkRelDir "_home/") -- | Convenience function to decode ByteString to String. decodeUtf8 :: BS.ByteString -> String -decodeUtf8 bs = T.unpack (T.decodeUtf8 (bs)) +decodeUtf8 bs = T.unpack (T.decodeUtf8 bs) -- | Convenience function constructing message for @$log*@. concatT :: [String] -> Text @@ -735,7 +735,7 @@ sandboxIDEnvVar = "DOCKER_SANDBOX_ID" -- | Environment variable used to indicate stack is running in container. inContainerEnvVar :: String -inContainerEnvVar = concat [map toUpper stackProgName,"_IN_CONTAINER"] +inContainerEnvVar = fmap toUpper stackProgName ++ "_IN_CONTAINER" -- | Command-line argument for "docker" dockerCmdName :: String @@ -781,10 +781,10 @@ data Inspect = Inspect instance FromJSON Inspect where parseJSON v = do o <- parseJSON v - (Inspect <$> o .: T.pack "Config" - <*> o .: T.pack "Created" - <*> o .: T.pack "Id" - <*> o .:? T.pack "VirtualSize") + Inspect <$> o .: T.pack "Config" + <*> o .: T.pack "Created" + <*> o .: T.pack "Id" + <*> o .:? T.pack "VirtualSize" -- | Parsed @Config@ section of @docker inspect@ output. data ImageConfig = ImageConfig @@ -795,7 +795,7 @@ data ImageConfig = ImageConfig instance FromJSON ImageConfig where parseJSON v = do o <- parseJSON v - (ImageConfig <$> o .:? T.pack "Env" .!= []) + ImageConfig <$> o .:? T.pack "Env" .!= [] -- | Exceptions thrown by Stack.Docker. data StackDockerException @@ -821,6 +821,8 @@ data StackDockerException -- ^ Installed version of @docker@ below minimum version. | DockerVersionProhibitedException [Version] Version -- ^ Installed version of @docker@ is prohibited. + | BadDockerVersionException VersionRange Version + -- ^ Installed version of @docker@ is out of range specified in config file. | InvalidVersionOutputException -- ^ Invalid output from @docker --version@. | HostStackTooOldException Version (Maybe Version) @@ -841,7 +843,7 @@ instance Exception StackDockerException -- | Show instance for StackDockerException. instance Show StackDockerException where show DockerMustBeEnabledException = - concat ["Docker must be enabled in your configuration file to use this command."] + "Docker must be enabled in your configuration file to use this command." show OnlyOnHostException = "This command must be run on host OS (not in a Docker container)." show (InspectFailedException image) = @@ -869,15 +871,26 @@ instance Show StackDockerException where show (DockerTooOldException minVersion haveVersion) = concat ["Minimum docker version '" ,versionString minVersion - ,"' is required (you have '" + ,"' is required by " + ,stackProgName + ," (you have '" ,versionString haveVersion ,"')."] show (DockerVersionProhibitedException prohibitedVersions haveVersion) = - concat ["These Docker versions are prohibited (you have '" + concat ["These Docker versions are incompatible with " + ,stackProgName + ," (you have '" ,versionString haveVersion ,"'): " - ,concat (intersperse ", " (map versionString prohibitedVersions)) + ,intercalate ", " (map versionString prohibitedVersions) ,"."] + show (BadDockerVersionException requiredRange haveVersion) = + concat ["The version of 'docker' you are using (" + ,show haveVersion + ,") is outside the required\n" + ,"version range specified in stack.yaml (" + ,T.unpack (versionRangeText requiredRange) + ,")."] show InvalidVersionOutputException = "Cannot get Docker version (invalid 'docker --version' output)." show (HostStackTooOldException minVersion (Just hostVersion)) = diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index 98139a803c..715edd6b7a 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -38,8 +38,7 @@ import Control.Monad (join, liftM, unless, void, import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (asks) -import Control.Monad.Reader (runReaderT) +import Control.Monad.Reader (asks, runReaderT) import Control.Monad.Trans.Control import Crypto.Hash (SHA512 (..)) import Data.ByteString (ByteString) @@ -52,7 +51,7 @@ import Data.IORef (newIORef, readIORef, writeIORef) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (maybeToList, catMaybes) @@ -80,6 +79,9 @@ import System.IO (IOMode (ReadMode), SeekMode (AbsoluteSeek), hSeek, withBinaryFile) import System.PosixCompat (setFileMode) +import Text.EditDistance as ED + +type PackageCaches = Map PackageIdentifier (PackageIndex, PackageCache) data FetchException = Couldn'tReadIndexTarball FilePath Tar.FormatError @@ -87,7 +89,7 @@ data FetchException | UnpackDirectoryAlreadyExists (Set FilePath) | CouldNotParsePackageSelectors [String] | UnknownPackageNames (Set PackageName) - | UnknownPackageIdentifiers (Set PackageIdentifier) + | UnknownPackageIdentifiers (Set PackageIdentifier) String deriving Typeable instance Exception FetchException @@ -113,9 +115,10 @@ instance Show FetchException where show (UnknownPackageNames names) = "The following packages were not found in your indices: " ++ intercalate ", " (map packageNameString $ Set.toList names) - show (UnknownPackageIdentifiers idents) = + show (UnknownPackageIdentifiers idents suggestions) = "The following package identifiers were not found in your indices: " ++ - intercalate ", " (map packageIdentifierString $ Set.toList idents) + intercalate ", " (map packageIdentifierString $ Set.toList idents) ++ + (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) @@ -195,14 +198,11 @@ resolvePackages menv idents0 names0 = do go >>= either throwM return Right x -> return x where - go = do - (missingNames, missingIdents, idents) <- resolvePackagesAllowMissing menv idents0 names0 - return $ - case () of - () - | not $ Set.null missingNames -> Left $ UnknownPackageNames missingNames - | not $ Set.null missingIdents -> Left $ UnknownPackageIdentifiers missingIdents - | otherwise -> Right idents + go = r <$> resolvePackagesAllowMissing menv idents0 names0 + r (missingNames, missingIdents, idents) + | not $ Set.null missingNames = Left $ UnknownPackageNames missingNames + | not $ Set.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" + | otherwise = Right idents resolvePackagesAllowMissing :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadThrow m, MonadBaseControl IO m, MonadCatch m) @@ -291,38 +291,40 @@ withCabalLoader menv inner = do -- Update the cache and try again Nothing -> do let fuzzy = fuzzyLookupCandidates ident cachesCurr - fuzzyCandidatesText = case fuzzy of - Nothing -> "" - Just cs -> "Possible candidates: " - <> commaSeparatedIdents cs - <> ". " + suggestions = case fuzzy of + Nothing -> + case typoCorrectionCandidates ident cachesCurr of + Nothing -> "" + Just cs -> "Perhaps you meant " <> + orSeparated cs <> "?" + Just cs -> "Possible candidates: " <> + commaSeparated (NE.map packageIdentifierString cs) + <> "." join $ modifyMVar updateRef $ \toUpdate -> if toUpdate then do runInBase $ do $logInfo $ T.concat [ "Didn't see " , T.pack $ packageIdentifierString ident - , " in your package indices. " - , T.pack fuzzyCandidatesText + , " in your package indices.\n" , "Updating and trying again." ] updateAllIndices menv caches <- getPackageCaches menv liftIO $ writeIORef icaches caches return (False, doLookup ident) - else return (toUpdate, throwM (unknownIdent ident)) + else return (toUpdate, + throwM $ UnknownPackageIdentifiers + (Set.singleton ident) suggestions) inner doLookup - where - unknownIdent = UnknownPackageIdentifiers . Set.singleton - commaSeparatedIdents = - F.fold . NonEmpty.intersperse ", " . NonEmpty.map packageIdentifierString - -type PackageCaches = Map PackageIdentifier (PackageIndex, PackageCache) -lookupPackageIdentifierExact :: HasConfig env - => PackageIdentifier -> env -> PackageCaches - -> IO (Maybe ByteString) -lookupPackageIdentifierExact ident env caches = do +lookupPackageIdentifierExact + :: HasConfig env + => PackageIdentifier + -> env + -> PackageCaches + -> IO (Maybe ByteString) +lookupPackageIdentifierExact ident env caches = case Map.lookup ident caches of Nothing -> return Nothing Just (index, cache) -> do @@ -331,21 +333,35 @@ lookupPackageIdentifierExact ident env caches = do $ \_ _ bs -> return bs return $ Just bs -fuzzyLookupCandidates :: PackageIdentifier -> PackageCaches - -> Maybe (NonEmpty PackageIdentifier) +-- | Given package identifier and package caches, return list of packages +-- with the same name and the same two first version number components found +-- in the caches. +fuzzyLookupCandidates + :: PackageIdentifier + -> PackageCaches + -> Maybe (NonEmpty PackageIdentifier) fuzzyLookupCandidates (PackageIdentifier name ver) caches = - NonEmpty.nonEmpty (map fst sameMajor) - where - sameMajor = filter (\(PackageIdentifier _ v, _) -> - toMajorVersion ver == toMajorVersion v) - sameIdentCaches - sameIdentCaches = maybe biggerFiltered - (\z -> (zeroIdent, z) : biggerFiltered) - zeroVer - biggerFiltered = takeWhile (\(PackageIdentifier n _, _) -> name == n) - (Map.toList bigger) - zeroIdent = PackageIdentifier name $(mkVersion "0.0") - (_, zeroVer, bigger) = Map.splitLookup zeroIdent caches + let (_, zero, bigger) = Map.splitLookup zeroIdent caches + zeroIdent = PackageIdentifier name $(mkVersion "0.0") + sameName (PackageIdentifier n _) = n == name + sameMajor (PackageIdentifier _ v) = toMajorVersion v == toMajorVersion ver + in NE.nonEmpty . filter sameMajor $ maybe [] (pure . const zeroIdent) zero + <> takeWhile sameName (Map.keys bigger) + +-- | Try to come up with typo corrections for given package identifier using +-- package caches. This should be called before giving up, i.e. when +-- 'fuzzyLookupCandidates' cannot return anything. +typoCorrectionCandidates + :: PackageIdentifier + -> PackageCaches + -> Maybe (NonEmpty String) +typoCorrectionCandidates ident = + let getName = packageNameString . packageIdentifierName + name = getName ident + in NE.nonEmpty + . Map.keys + . Map.filterWithKey (const . (== 1) . damerauLevenshtein name) + . Map.mapKeys getName -- | Figure out where to fetch from. getToFetch :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env) @@ -435,10 +451,10 @@ fetchPackages' mdistDir toFetchAll = do let downloadReq = DownloadRequest { drRequest = req , drHashChecks = map toHashCheck $ maybeToList (tfSHA512 toFetch) - , drLengthCheck = fmap fromIntegral $ tfSize toFetch + , drLengthCheck = fromIntegral <$> tfSize toFetch , drRetryPolicy = drRetryPolicyDefault } - let progressSink _ = do + let progressSink _ = liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download" _ <- verifiedDownload downloadReq destpath progressSink @@ -523,3 +539,15 @@ parMapM_ cnt f xs0 = do workers 1 = Concurrently worker workers i = Concurrently worker *> workers (i - 1) liftIO $ runConcurrently $ workers cnt + +damerauLevenshtein :: String -> String -> Int +damerauLevenshtein = ED.restrictedDamerauLevenshteinDistance ED.defaultEditCosts + +orSeparated :: NonEmpty String -> String +orSeparated xs + | NE.length xs == 1 = NE.head xs + | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs + | otherwise = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs + +commaSeparated :: NonEmpty String -> String +commaSeparated = F.fold . NE.intersperse ", " diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index 7b0b81bf3d..33b5ebbb37 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -67,12 +67,11 @@ ghcPkg :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadT -> m (Either ReadProcessException S8.ByteString) ghcPkg menv wc pkgDbs args = do eres <- go - r <- case eres of - Left _ -> do - mapM_ (createDatabase menv wc) pkgDbs - go - Right _ -> return eres - return r + case eres of + Left _ -> do + mapM_ (createDatabase menv wc) pkgDbs + go + Right _ -> return eres where go = tryProcessStdout Nothing menv (ghcPkgExeName wc) args' args' = packageDbFlags pkgDbs ++ args @@ -99,7 +98,7 @@ ghcPkgExeName Ghcjs = "ghcjs-pkg" packageDbFlags :: [Path Abs Dir] -> [String] packageDbFlags pkgDbs = "--no-user-package-db" - : map (\x -> ("--package-db=" ++ toFilePath x)) pkgDbs + : map (\x -> "--package-db=" ++ toFilePath x) pkgDbs -- | Get the value of a field of the package. findGhcPkgField diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 77be604f91..346ba69bb2 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -5,11 +5,18 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} --- | Run a GHCi configured with the user's project(s). +-- | Run a GHCi configured with the user's package(s). -module Stack.Ghci (GhciOpts(..),GhciPkgInfo(..), ghciSetup, ghci) where +module Stack.Ghci + ( GhciOpts(..) + , GhciPkgInfo(..) + , GhciException(..) + , ghciSetup + , ghci + ) where import Control.Monad.Catch +import Control.Exception.Enclosed (tryAny) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader @@ -17,14 +24,18 @@ import Control.Monad.Trans.Resource import Data.Either import Data.Function import Data.List +import Data.List.Extra (nubOrd) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe +import Data.Maybe.Extra (forMaybeM) import Data.Monoid import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Data.Typeable (Typeable) import Distribution.ModuleName (ModuleName) import Distribution.Text (display) import Network.HTTP.Client.Conduit @@ -44,41 +55,51 @@ import System.Directory (getTemporaryDirectory) -- | Command-line options for GHC. data GhciOpts = GhciOpts - {ghciTargets :: ![Text] - ,ghciArgs :: ![String] - ,ghciGhcCommand :: !(Maybe FilePath) - ,ghciNoLoadModules :: !Bool - ,ghciAdditionalPackages :: ![String] - ,ghciMainIs :: !(Maybe Text) - } deriving (Show,Eq) + { ghciNoBuild :: !Bool + , ghciArgs :: ![String] + , ghciGhcCommand :: !(Maybe FilePath) + , ghciNoLoadModules :: !Bool + , ghciAdditionalPackages :: ![String] + , ghciMainIs :: !(Maybe Text) + , ghciBuildOpts :: !BuildOpts + } deriving Show -- | Necessary information to load a package or its components. data GhciPkgInfo = GhciPkgInfo - { ghciPkgName :: PackageName - , ghciPkgOpts :: [String] - , ghciPkgDir :: Path Abs Dir - , ghciPkgModules :: Set ModuleName - , ghciPkgModFiles :: Set (Path Abs File) -- ^ Module file paths. - , ghciPkgCFiles :: Set (Path Abs File) -- ^ C files. - , ghciPkgMainIs :: Map NamedComponent (Set (Path Abs File)) - } + { ghciPkgName :: !PackageName + , ghciPkgOpts :: ![(NamedComponent, BuildInfoOpts)] + , ghciPkgOmittedOpts :: ![String] + , ghciPkgDir :: !(Path Abs Dir) + , ghciPkgModules :: !(Set ModuleName) + , ghciPkgModFiles :: !(Set (Path Abs File)) -- ^ Module file paths. + , ghciPkgCFiles :: !(Set (Path Abs File)) -- ^ C files. + , ghciPkgMainIs :: !(Map NamedComponent (Set (Path Abs File))) + , ghciPkgPackage :: !Package + } deriving Show --- | Launch a GHCi session for the given local project targets with the +-- | Launch a GHCi session for the given local package targets with the -- given options and configure it with the load paths and extensions -- of those targets. ghci :: (HasConfig r, HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) => GhciOpts -> m () ghci GhciOpts{..} = do - (targets,mainIsTargets,pkgs) <- ghciSetup ghciMainIs ghciTargets + let bopts = ghciBuildOpts + { boptsTestOpts = (boptsTestOpts ghciBuildOpts) { toDisableRun = True } + , boptsBenchmarkOpts = (boptsBenchmarkOpts ghciBuildOpts) { beoDisableRun = True } + } + (targets,mainIsTargets,pkgs) <- ghciSetup bopts ghciNoBuild ghciMainIs bconfig <- asks getBuildConfig - mainFile <- figureOutMainFile mainIsTargets targets pkgs + mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs wc <- getWhichCompiler - let pkgopts = concatMap ghciPkgOpts pkgs + let pkgopts = + (if null pkgs then [] else ["-hide-all-packages"]) ++ + nubOrd (concatMap (concatMap (bioGeneratedOpts . snd) . ghciPkgOpts) pkgs) ++ + concatMap (concatMap (bioGhcOpts . snd) . ghciPkgOpts) pkgs modulesToLoad | ghciNoLoadModules = [] | otherwise = - nub + nubOrd (maybe [] (return . toFilePath) mainFile <> concatMap (map display . S.toList . ghciPkgModules) pkgs) odir = @@ -94,13 +115,16 @@ ghci GhciOpts{..} = do (\tmpDir -> do let scriptPath = tmpDir $(mkRelFile "ghci-script") fp = toFilePath scriptPath - loadModules = ":l " <> unwords modulesToLoad - bringIntoScope = ":m + " <> unwords modulesToLoad + loadModules = ":load " <> unwords modulesToLoad + bringIntoScope = ":module + " <> unwords modulesToLoad liftIO (writeFile fp (unlines [loadModules,bringIntoScope])) finally (exec defaultEnvSettings (fromMaybe (compilerExeName wc) ghciGhcCommand) ("--interactive" : + -- This initial "-i" resets the include directories to not + -- include CWD. + "-i" : odir <> pkgopts <> ghciArgs <> ["-ghci-script=" <> fp])) (removeFile scriptPath)) @@ -110,19 +134,18 @@ ghci GhciOpts{..} = do -- ambiguous. Warns and returns nothing if it's ambiguous. figureOutMainFile :: (Monad m, MonadLogger m) - => Maybe (Map PackageName SimpleTarget) + => BuildOpts + -> Maybe (Map PackageName SimpleTarget) -> Map PackageName SimpleTarget -> [GhciPkgInfo] -> m (Maybe (Path Abs File)) -figureOutMainFile mainIsTargets targets0 packages = do +figureOutMainFile bopts mainIsTargets targets0 packages = case candidates of [] -> return Nothing [c@(_,_,fp)] -> do $logInfo ("Using main module: " <> renderCandidate c) return (Just fp) - candidate:_ -> do - let border = $logWarn "* * * * * * * *" - border - $logWarn ("The main module to load is ambiguous. Candidates are: ") + candidate:_ -> borderedWarning $ do + $logWarn "The main module to load is ambiguous. Candidates are: " forM_ (map renderCandidate candidates) $logWarn $logWarn "None will be loaded. You can specify which one to pick by: " @@ -132,7 +155,6 @@ figureOutMainFile mainIsTargets targets0 packages = do $logWarn (" 2) Specifying what the main is e.g. stack ghci " <> sampleMainIsArg candidate) - border return Nothing where targets = fromMaybe targets0 mainIsTargets @@ -142,15 +164,14 @@ figureOutMainFile mainIsTargets targets0 packages = do Nothing -> [] Just target -> do (component,mains) <- - M.toList - (M.filterWithKey wantedComponent (ghciPkgMainIs pkg)) + M.toList $ + M.filterWithKey (\k _ -> k `S.member` wantedComponents) + (ghciPkgMainIs pkg) main <- S.toList mains return (ghciPkgName pkg, component, main) - where wantedComponent namedC _ = - case target of - STLocalAll -> True - STLocalComps cs -> S.member namedC cs - _ -> False + where + wantedComponents = + wantedPackageComponents bopts target (ghciPkgPackage pkg) renderCandidate (pkgName,namedComponent,mainIs) = "Package `" <> packageNameText pkgName <> "' component " <> renderComp namedComponent <> @@ -171,28 +192,18 @@ figureOutMainFile mainIsTargets targets0 packages = do -- 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, MonadCatch m, MonadBaseControl IO m) - => Maybe Text - -> [Text] + => BuildOpts + -> Bool + -> Maybe Text -> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo]) -ghciSetup mainIs stringTargets = do - (_,_,targets) <- - parseTargetsFromBuildOpts - AllowNoTargets - defaultBuildOpts - { boptsTargets = stringTargets - } +ghciSetup bopts noBuild mainIs = do + (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets bopts mainIsTargets <- case mainIs of Nothing -> return Nothing Just target -> do - (_,_,targets') <- - parseTargetsFromBuildOpts - AllowNoTargets - defaultBuildOpts - { boptsTargets = [target] - } + (_,_,targets') <- parseTargetsFromBuildOpts AllowNoTargets bopts { boptsTargets = [target] } return (Just targets') - let bopts = makeBuildOpts targets econfig <- asks getEnvConfig (realTargets,_,_,_,sourceMap) <- loadSourceMap AllowNoTargets bopts menv <- getMinimalEnvOverride @@ -204,8 +215,7 @@ ghciSetup mainIs stringTargets = do } sourceMap locals <- - liftM catMaybes $ - forM (M.toList (envConfigPackages econfig)) $ + forMaybeM (M.toList (envConfigPackages econfig)) $ \(dir,validWanted) -> do cabalfp <- getCabalFileName dir name <- parsePackageNameFromFilePath cabalfp @@ -215,114 +225,166 @@ ghciSetup mainIs stringTargets = do return (Just (name, (cabalfp, simpleTargets))) Nothing -> return Nothing else return Nothing - let localLibs = [name | (name, (_, target)) <- locals, targetIncludesLib target] + -- Try to build, but optimistically launch GHCi anyway if it fails (#1065) + unless noBuild $ do + eres <- tryAny $ build (const (return ())) Nothing bopts + case eres of + Right () -> return () + Left err -> do + $logError $ T.pack (show err) + $logWarn "Warning: build failed, but optimistically launching GHCi anyway" + -- Load the list of modules _after_ building, to catch changes in unlisted dependencies (#1180) + let localLibs = [name | (name, (_, target)) <- locals, hasLocalComp isCLib target] infos <- forM locals $ - \(name,(cabalfp,component)) -> - makeGhciPkgInfo sourceMap installedMap localLibs name cabalfp component - unless (M.null realTargets) (build (const (return ())) Nothing bopts) + \(name,(cabalfp,target)) -> + makeGhciPkgInfo bopts sourceMap installedMap localLibs name cabalfp target + checkForIssues infos return (realTargets, mainIsTargets, infos) where - -- NOTE: this doesn't mean that the cabal package actually has a - -- library, just that if it does, the requested target includes it. - targetIncludesLib STLocalAll = True - targetIncludesLib (STLocalComps comps) = S.member CLib comps - targetIncludesLib _ = False - makeBuildOpts targets = - base - { boptsTargets = stringTargets - , boptsTests = any (hasLocalComp isCTest) elems - , boptsBenchmarks = any (hasLocalComp isCBench) elems - , boptsTestOpts = (boptsTestOpts base) - { toDisableRun = True - , toRerunTests = False - } - , boptsBenchmarkOpts = (boptsBenchmarkOpts base) - { beoDisableRun = True - } - , boptsBuildSubset = BSOnlyDependencies - } - where - base = defaultBuildOpts - elems = M.elems targets - hasLocalComp p t = - case t of - STLocalComps s -> any p (S.toList s) - STLocalAll -> True - _ -> False - isCTest nc = - case nc of - CTest{} -> True - _ -> False - isCBench nc = - case nc of - CBench{} -> True - _ -> False + hasLocalComp p t = + case t of + STLocalComps s -> any p (S.toList s) + STLocalAll -> True + _ -> False -- | Make information necessary to load the given package in GHCi. makeGhciPkgInfo :: (MonadReader r m, HasEnvConfig r, MonadLogger m, MonadIO m, MonadCatch m) - => SourceMap + => BuildOpts + -> SourceMap -> InstalledMap -> [PackageName] -> PackageName -> Path Abs File -> SimpleTarget -> m GhciPkgInfo -makeGhciPkgInfo sourceMap installedMap locals name cabalfp component = do +makeGhciPkgInfo bopts sourceMap installedMap locals name cabalfp target = do econfig <- asks getEnvConfig bconfig <- asks getBuildConfig let config = PackageConfig { packageConfigEnableTests = True , packageConfigEnableBenchmarks = True - , packageConfigFlags = localFlags mempty bconfig name + , packageConfigFlags = localFlags (boptsFlags bopts) bconfig name , packageConfigCompilerVersion = envConfigCompilerVersion econfig , packageConfigPlatform = configPlatform (getConfig bconfig) } (warnings,pkg) <- readPackage config cabalfp + let filterWanted = M.filterWithKey (\k _ -> k `S.member` allWanted) + allWanted = wantedPackageComponents bopts target pkg mapM_ (printCabalFileWarning cabalfp) warnings - (componentsModules,componentFiles,componentsOpts,generalOpts) <- - getPackageOpts (packageOpts pkg) sourceMap installedMap locals cabalfp - let filterWithinWantedComponents m = - M.elems - (M.filterWithKey - (\k _ -> - case component of - STLocalComps cs -> S.member k cs - _ -> True) - m) - filteredOptions = - nub (map - (\x -> - if badForGhci x - then Left x - else Right x) - (generalOpts <> - concat (filterWithinWantedComponents componentsOpts))) - case lefts filteredOptions of - [] -> return () - options -> - $logWarn - ("The following GHC options are incompatible with GHCi and have not been passed to it: " <> - T.unwords (map T.pack options)) + (mods,files,opts) <- getPackageOpts (packageOpts pkg) sourceMap installedMap locals cabalfp + let filteredOpts = filterWanted opts + omitUnwanted bio = bio { bioGhcOpts = filter (not . badForGhci) (bioGhcOpts bio) } + omitted = filter badForGhci $ concatMap bioGhcOpts (M.elems filteredOpts) return GhciPkgInfo { ghciPkgName = packageName pkg - , ghciPkgOpts = rights filteredOptions + , ghciPkgOpts = M.toList (M.map omitUnwanted filteredOpts) + , ghciPkgOmittedOpts = omitted , ghciPkgDir = parent cabalfp - , ghciPkgModules = mconcat - (filterWithinWantedComponents componentsModules) - , ghciPkgModFiles = mconcat - (filterWithinWantedComponents - (M.map (setMapMaybe dotCabalModulePath) componentFiles)) - , ghciPkgMainIs = M.map (setMapMaybe dotCabalMainPath) componentFiles - , ghciPkgCFiles = mconcat - (filterWithinWantedComponents - (M.map (setMapMaybe dotCabalCFilePath) componentFiles)) + , ghciPkgModules = mconcat (M.elems (filterWanted mods)) + , ghciPkgModFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalModulePath) files))) + , ghciPkgMainIs = M.map (setMapMaybe dotCabalMainPath) files + , ghciPkgCFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalCFilePath) files))) + , ghciPkgPackage = pkg } where badForGhci :: String -> Bool badForGhci x = isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky -static") setMapMaybe f = S.fromList . mapMaybe f . S.toList + +-- NOTE: this should make the same choices as the components code in +-- 'loadLocalPackage'. Unfortunately for now we reiterate this logic +-- (differently). +wantedPackageComponents :: BuildOpts -> SimpleTarget -> Package -> Set NamedComponent +wantedPackageComponents _ (STLocalComps cs) _ = cs +wantedPackageComponents bopts STLocalAll pkg = S.fromList $ + (if packageHasLibrary pkg then [CLib] else []) ++ + map CExe (S.toList (packageExes pkg)) <> + (if boptsTests bopts then map CTest (S.toList (packageTests pkg)) else []) <> + (if boptsBenchmarks bopts then map CBench (S.toList (packageBenchmarks pkg)) else []) +wantedPackageComponents _ _ _ = S.empty + +checkForIssues :: (MonadThrow m, MonadLogger m) => [GhciPkgInfo] -> m () +checkForIssues pkgs = do + let unbuildable = filter (\(_, bio) -> not (bioBuildable bio)) compsWithBios + unless (null unbuildable) $ + throwM (SomeTargetsNotBuildable (map fst unbuildable)) + let omitted = concatMap ghciPkgOmittedOpts pkgs + unless (null omitted) $ + $logWarn + ("The following GHC options are incompatible with GHCi and have not been passed to it: " <> + T.unwords (map T.pack (nubOrd omitted))) + unless (null issues) $ borderedWarning $ do + $logWarn "There are issues with this project which may prevent GHCi from working properly." + $logWarn "" + mapM_ $logWarn $ intercalate [""] issues + $logWarn "" + $logWarn "To resolve, remove the flag(s) from the cabal file(s) and instead put them at the top of the haskell files." + $logWarn "" + $logWarn "It isn't yet possible to load multiple packages into GHCi in all cases - see" + $logWarn "https://ghc.haskell.org/trac/ghc/ticket/10827" + where + issues = concat + [ mixedFlag "-XNoImplicitPrelude" + [ "-XNoImplicitPrelude will be used, but GHCi will likely fail to build things which depend on the implicit prelude." ] + , mixedFlag "-XCPP" + [ "-XCPP will be used, but it can cause issues with multiline strings." + , "See https://downloads.haskell.org/~ghc/7.10.2/docs/html/users_guide/options-phases.html#cpp-string-gaps" + ] + , mixedFlag "-XNoTraditionalRecordSyntax" + [ "-XNoTraditionalRecordSyntax will be used, but it break modules which use record syntax." ] + , mixedFlag "-XTemplateHaskell" + [ "-XTemplateHaskell will be used, but it may cause compilation issues due to different parsing of ($)." ] + , mixedFlag "-XSafe" + [ "-XSafe will be used, but it will fail to compile unsafe modules." ] + ] + mixedFlag flag msgs = + let x = partitionComps (== flag) in + [ msgs ++ showWhich x | mixedSettings x ] + mixedSettings (xs, ys) = xs /= [] && ys /= [] + showWhich (haveIt, don'tHaveIt) = + [ "It is specified for:" + , " " <> renderPkgComps haveIt + , "But not for: " + , " " <> renderPkgComps don'tHaveIt + ] + partitionComps f = (map fst xs, map fst ys) + where + (xs, ys) = partition (any f . snd) compsWithOpts + compsWithOpts = map (\(k, bio) -> (k, bioGeneratedOpts bio ++ bioGhcOpts bio)) compsWithBios + compsWithBios = concat + [ [ ((ghciPkgName pkg, c), bio) + | (c, bio) <- ghciPkgOpts pkg + ] + | pkg <- pkgs ] + +borderedWarning :: MonadLogger m => m a -> m a +borderedWarning f = do + $logWarn "" + $logWarn "* * * * * * * *" + x <- f + $logWarn "* * * * * * * *" + $logWarn "" + return x + +renderPkgComps :: [(PackageName, NamedComponent)] -> Text +renderPkgComps = T.intercalate " " . map renderPkgComp + +renderPkgComp :: (PackageName, NamedComponent) -> Text +renderPkgComp (pkg, comp) = packageNameText pkg <> ":" <> decodeUtf8 (renderComponent comp) + +data GhciException = + SomeTargetsNotBuildable [(PackageName, NamedComponent)] + deriving (Typeable) + +instance Exception GhciException + +instance Show GhciException where + show (SomeTargetsNotBuildable xs) = + "The following components have 'buildable: False' in cabal, and so cannot be ghci targets:\n " ++ + T.unpack (renderPkgComps xs) ++ + "\nTo resolve this, either specify flags such that these components are buildable, or pass buildable targets to \"stack ghci\"." diff --git a/src/Stack/Ide.hs b/src/Stack/Ide.hs index 7c3f28d37e..3e6754b2b2 100644 --- a/src/Stack/Ide.hs +++ b/src/Stack/Ide.hs @@ -1,12 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} --- | Run a IDE configured with the user's project(s). +-- | Run a IDE configured with the user's package(s). module Stack.Ide (ide, getPackageOptsAndTargetFiles) @@ -34,6 +33,7 @@ import Stack.Types.Internal import System.Environment (lookupEnv) import System.Process.Run import System.FilePath (searchPathSeparator) + -- | Launch a GHCi IDE for the given local project targets with the -- given options and configure it with the load paths and extensions -- of those targets. @@ -43,7 +43,11 @@ ide -> [String] -- ^ GHC options. -> m () ide targets useropts = do - (_realTargets,_,pkgs) <- ghciSetup Nothing targets + let bopts = defaultBuildOpts + { boptsTargets = targets + , boptsBuildSubset = BSOnlyDependencies + } + (_realTargets,_,pkgs) <- ghciSetup bopts False Nothing pwd <- getWorkingDir (pkgopts,_srcfiles) <- liftM mconcat $ forM pkgs $ getPackageOptsAndTargetFiles pwd @@ -56,7 +60,7 @@ ide targets useropts = do paths = [ "--ide-backend-tools-path=" <> intercalate [searchPathSeparator] (map toFilePath bindirs) <> - (maybe "" (searchPathSeparator :) mpath)] + maybe "" (searchPathSeparator :) mpath] args = ["--verbose"] <> ["--include=" <> includeDirs pkgopts] <> ["--local-work-dir=" ++ toFilePath pwd] <> @@ -85,7 +89,7 @@ getPackageOptsAndTargetFiles => Path Abs Dir -> GhciPkgInfo -> m ([FilePath], [FilePath]) getPackageOptsAndTargetFiles pwd pkg = do dist <- distDirFromDir (ghciPkgDir pkg) - autogen <- return (autogenDir dist) + let autogen = autogenDir dist paths_foo <- liftM (autogen ) @@ -93,11 +97,9 @@ getPackageOptsAndTargetFiles pwd pkg = do ("Paths_" ++ packageNameString (ghciPkgName pkg) ++ ".hs")) paths_foo_exists <- fileExists paths_foo return - ( ["--dist-dir=" <> toFilePath dist] ++ - map ("--ghc-option=" ++) (ghciPkgOpts pkg) + ( ("--dist-dir=" <> toFilePath dist) : + map ("--ghc-option=" ++) (concatMap (\(_, bio) -> bioGeneratedOpts bio ++ bioGhcOpts bio) (ghciPkgOpts pkg)) , mapMaybe (fmap toFilePath . stripDir pwd) (S.toList (ghciPkgCFiles pkg) <> S.toList (ghciPkgModFiles pkg) <> - if paths_foo_exists - then [paths_foo] - else [])) + [paths_foo | paths_foo_exists])) diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs index a151f7114a..1dc111cad5 100644 --- a/src/Stack/Image.hs +++ b/src/Stack/Image.hs @@ -35,7 +35,7 @@ import Path.IO import Stack.Constants import Stack.Types import Stack.Types.Internal -import System.Process +import System.Process.Run type Build e m = (HasBuildConfig e, HasConfig e, HasEnvConfig e, HasTerminal e, MonadBaseControl IO m, MonadCatch m, MonadIO m, MonadLogger m, MonadReader e m) @@ -101,30 +101,34 @@ imageName = map toLower . toFilePathNoTrailingSep . dirname -- directory of executables & static content. createDockerImage :: Assemble e m => Path Abs Dir -> m () createDockerImage dir = do + menv <- getMinimalEnvOverride config <- asks getConfig let dockerConfig = imgDocker (configImage config) case imgDockerBase =<< dockerConfig of Nothing -> throwM StackImageDockerBaseUnspecifiedException Just base -> do liftIO - (do writeFile - (toFilePath - (dir - $(mkRelFile "Dockerfile"))) - (unlines ["FROM " ++ base, "ADD ./ /"]) - callProcess - "docker" - [ "build" - , "-t" - , fromMaybe - (imageName (parent (parent dir))) - (imgDockerImageName =<< dockerConfig) - , toFilePath dir]) + (writeFile + (toFilePath + (dir + $(mkRelFile "Dockerfile"))) + (unlines ["FROM " ++ base, "ADD ./ /"])) + callProcess + Nothing + menv + "docker" + [ "build" + , "-t" + , fromMaybe + (imageName (parent (parent dir))) + (imgDockerImageName =<< dockerConfig) + , toFilePath dir] -- | Extend the general purpose docker image with entrypoints (if -- specified). extendDockerImageWithEntrypoint :: Assemble e m => Path Abs Dir -> m () extendDockerImageWithEntrypoint dir = do + menv <- getMinimalEnvOverride config <- asks getConfig let dockerConfig = imgDocker (configImage config) let dockerImageName = fromMaybe @@ -133,26 +137,28 @@ extendDockerImageWithEntrypoint dir = do let imgEntrypoints = maybe Nothing imgDockerEntrypoints dockerConfig case imgEntrypoints of Nothing -> return () - Just eps -> do + Just eps -> forM_ eps - (\ep -> + (\ep -> do liftIO - (do writeFile - (toFilePath - (dir - $(mkRelFile "Dockerfile"))) - (unlines - [ "FROM " ++ dockerImageName - , "ENTRYPOINT [\"/usr/local/bin/" ++ - ep ++ "\"]" - , "CMD []"]) - callProcess - "docker" - [ "build" - , "-t" - , dockerImageName ++ "-" ++ ep - , toFilePath dir])) + (writeFile + (toFilePath + (dir + $(mkRelFile "Dockerfile"))) + (unlines + [ "FROM " ++ dockerImageName + , "ENTRYPOINT [\"/usr/local/bin/" ++ + ep ++ "\"]" + , "CMD []"])) + callProcess + Nothing + menv + "docker" + [ "build" + , "-t" + , dockerImageName ++ "-" ++ ep + , toFilePath dir]) -- | The command name for dealing with images. imgCmdName :: String diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 83af318ea6..00ca8a7110 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -15,7 +15,7 @@ module Stack.Init import Control.Exception (assert) import Control.Exception.Enclosed (catchAny, handleIO) -import Control.Monad (liftM, when) +import Control.Monad (liftM, when, zipWithM_) import Control.Monad.Catch (MonadMask, MonadThrow, throwM) import Control.Monad.IO.Class import Control.Monad.Logger @@ -26,7 +26,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IntMap import qualified Data.Foldable as F -import Data.List (isSuffixOf,sort) +import Data.List (isSuffixOf,sortBy) import Data.List.Extra (nubOrd) import Data.Map (Map) import qualified Data.Map as Map @@ -86,7 +86,7 @@ initProject currDir initOpts = do when (null cabalfps) $ error "In order to init, you should have an existing .cabal file. Please try \"stack new\" instead" (warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) - sequence_ (zipWith (mapM_ . printCabalFileWarning) cabalfps warnings) + zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings (r, flags, extraDeps) <- getDefaultResolver cabalfps gpds initOpts let p = Project @@ -227,7 +227,7 @@ getRecommendedSnapshots snapshots pref = do -- prefer them over anything else, since odds are high that something -- already exists for them. existing <- - liftM (reverse . sort . mapMaybe (parseSnapName . T.pack)) $ + liftM (sortBy (flip compare) . mapMaybe (parseSnapName . T.pack)) $ snapshotsDir >>= liftIO . handleIO (const $ return []) . getDirectoryContents . toFilePath @@ -290,7 +290,7 @@ makeConcreteResolver ar = do Nothing -> error $ "No LTS release found with major version " ++ show x Just y -> return $ ResolverSnapshot $ LTS x y ARLatestLTS - | IntMap.null $ snapshotsLts snapshots -> error $ "No LTS releases found" + | IntMap.null $ snapshotsLts snapshots -> error "No LTS releases found" | otherwise -> let (x, y) = IntMap.findMax $ snapshotsLts snapshots in return $ ResolverSnapshot $ LTS x y diff --git a/src/Stack/New.hs b/src/Stack/New.hs index e927225b1a..d8ad847df2 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -30,7 +30,7 @@ import Data.Conduit import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe +import Data.Maybe.Extra (mapMaybeM) import Data.Monoid import Data.Set (Set) import qualified Data.Set as S @@ -163,7 +163,7 @@ applyTemplate project template nonceParams dir templateText = do defaultConfig templateText (mkStrContextM (contextFunction context))) - when (not (S.null missingKeys)) + unless (S.null missingKeys) ($logInfo (T.pack (show (MissingParameters project template missingKeys (configUserConfigPath config))))) files :: Map FilePath LB.ByteString <- execWriterT $ @@ -185,7 +185,7 @@ applyTemplate project template nonceParams dir templateText = do => Map Text Text -> String -> WriterT (Set String) m (MuType (WriterT (Set String) m)) - contextFunction context key = do + contextFunction context key = case M.lookup (T.pack key) context of Nothing -> do tell (S.singleton key) @@ -196,7 +196,7 @@ applyTemplate project template nonceParams dir templateText = do writeTemplateFiles :: MonadIO m => Map (Path Abs File) LB.ByteString -> m () -writeTemplateFiles files = do +writeTemplateFiles files = forM_ (M.toList files) (\(fp,bytes) -> @@ -213,9 +213,8 @@ runTemplateInits dir = do case configScmInit config of Nothing -> return () Just Git -> - do catch - (callProcess (Just dir) menv "git" ["init"]) - (\(_ :: ProcessExitedUnsuccessfully) -> + catch (callProcess (Just dir) menv "git" ["init"]) + (\(_ :: ProcessExitedUnsuccessfully) -> $logInfo "git init failed to run, ignoring ...") -------------------------------------------------------------------------------- @@ -254,12 +253,12 @@ getTemplates = do parseTemplateSet :: Value -> Parser (Set TemplateName) parseTemplateSet a = do xs <- parseJSON a - fmap (S.fromList . catMaybes) (mapM parseTemplate xs) + fmap S.fromList (mapMaybeM parseTemplate xs) where parseTemplate v = do o <- parseJSON v name <- o .: "name" - if isSuffixOf ".hsfiles" name + if ".hsfiles" `isSuffixOf` name then case parseTemplateNameFromString name of Left{} -> fail ("Unable to parse template name from " <> name) diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 7105710848..274c923151 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -20,6 +20,7 @@ module Stack.Options ,testOptsParser ,hpcReportOptsParser ,pvpBoundsOption + ,globalOptsFromMonoid ) where import Control.Monad.Logger (LogLevel(..)) @@ -34,9 +35,10 @@ import Data.Monoid import qualified Data.Set as Set import qualified Data.Text as T import Data.Text.Read (decimal) +import Distribution.Version (anyVersion) +import Options.Applicative import Options.Applicative.Args import Options.Applicative.Builder.Extra -import Options.Applicative.Simple import Options.Applicative.Types (fromM, oneM, readerAsk) import Stack.Config (packagesParser) import Stack.ConfigCmd @@ -104,7 +106,7 @@ buildOptsParser cmd = haddock = boolFlags (cmd == Haddock) "haddock" - "generating Haddocks the project(s) in this directory/configuration" + "generating Haddocks the package(s) in this directory/configuration" idm haddockDeps = maybeBoolFlags @@ -143,15 +145,15 @@ buildOptsParser cmd = help "Fetch packages necessary for the build immediately, useful with --dry-run") buildSubset = - flag' BSOnlySnapshot - (long "only-snapshot" <> - help "Only build packages for the snapshot database, not the local database") - <|> flag' BSOnlyDependencies - (long "only-dependencies" <> - help "Only build packages that are dependencies of targets on the command line") - <|> flag' BSOnlyDependencies + flag' BSOnlyDependencies (long "dependencies-only" <> help "A synonym for --only-dependencies") + <|> flag' BSOnlySnapshot + (long ("only-snapshot") <> + help ("Only build packages for the snapshot database, not the local database")) + <|> flag' BSOnlyDependencies + (long ("only-dependencies") <> + help ("Only build packages that are dependencies of targets on the command line")) <|> pure BSAll fileWatch' = @@ -174,12 +176,12 @@ buildOptsParser cmd = tests = boolFlags (cmd == Test) "test" - "testing the project(s) in this directory/configuration" + "testing the package(s) in this directory/configuration" idm benches = boolFlags (cmd == Bench) "bench" - "benchmarking the project(s) in this directory/configuration" + "benchmarking the package(s) in this directory/configuration" idm exec = cmdOption @@ -224,7 +226,7 @@ readFlag = do -- | Command-line arguments parser for configuration. configOptsParser :: Bool -> Parser ConfigMonoid -configOptsParser docker = +configOptsParser hide0 = (\opts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage -> mempty { configMonoidDockerOpts = opts , configMonoidSystemGHC = systemGHC @@ -240,63 +242,70 @@ configOptsParser docker = , configMonoidLocalBinPath = localBin , configMonoidModifyCodePage = modifyCodePage }) - <$> dockerOptsParser docker + <$> dockerOptsParser True <*> maybeBoolFlags "system-ghc" "using the system installed GHC (on the PATH) if available and a matching version" - idm + hide <*> maybeBoolFlags "install-ghc" "downloading and installing GHC if necessary (can be done manually with stack setup)" - idm + hide <*> optional (strOption ( long "arch" <> metavar "ARCH" <> help "System architecture, e.g. i386, x86_64" + <> hide )) <*> optional (strOption ( long "os" <> metavar "OS" <> help "Operating system, e.g. linux, windows" + <> hide )) - <*> optional ghcVariantParser + <*> optional (ghcVariantParser hide0) <*> optional (option auto ( long "jobs" <> short 'j' <> metavar "JOBS" <> help "Number of concurrent jobs to run" + <> hide )) <*> fmap Set.fromList (many (textOption ( long "extra-include-dirs" <> metavar "DIR" <> help "Extra directories to check for C header files" + <> hide ))) <*> fmap Set.fromList (many (textOption ( long "extra-lib-dirs" <> metavar "DIR" <> help "Extra directories to check for libraries" + <> hide ))) <*> maybeBoolFlags "skip-ghc-check" "skipping the GHC version and architecture check" - idm + hide <*> maybeBoolFlags "skip-msys" "skipping the local MSYS installation (Windows only)" - idm + hide <*> optional (strOption ( long "local-bin-path" - <> metavar "DIR" - <> help "Install binaries to DIR" - )) + <> metavar "DIR" + <> help "Install binaries to DIR" + <> hide + )) <*> maybeBoolFlags "modify-code-page" "setting the codepage to support UTF-8 (Windows only)" - idm + hide + where hide = hideMods hide0 -- | Options parser configuration for Docker. dockerOptsParser :: Bool -> Parser DockerOptsMonoid -dockerOptsParser showOptions = +dockerOptsParser hide0 = DockerOptsMonoid <$> pure False <*> maybeBoolFlags dockerCmdName @@ -368,12 +377,11 @@ dockerOptsParser showOptions = <*> maybeBoolFlags (dockerOptName dockerSetUserArgName) "setting user in container to match host" hide + <*> pure anyVersion where dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName maybeStrOption = optional . option str - hide = if showOptions - then idm - else internal <> hidden + hide = hideMods hide0 -- | Parser for docker cleanup arguments. dockerCleanupOptsParser :: Parser Docker.CleanupOpts @@ -453,19 +461,15 @@ dotOptsParser = DotOpts ghciOptsParser :: Parser GhciOpts ghciOptsParser = GhciOpts - <$> many (textArgument - (metavar "TARGET" <> - help ("If none specified, " <> - "use all packages defined in current directory"))) - <*> fmap concat (many (argsOption (long "ghc-options" <> + <$> switch (long "no-build" <> help "Don't build before launching GHCi") + <*> fmap concat (many (argsOption (long "ghci-options" <> metavar "OPTION" <> help "Additional options passed to GHCi"))) <*> optional (strOption (long "with-ghc" <> metavar "GHC" <> - help "Use this command for the GHC to run")) - <*> switch (long "no-load" <> - help "Don't load modules on start-up") + help "Use this GHC to run GHCi")) + <*> (not <$> boolFlags True "load" "load modules on start-up" idm) <*> packagesParser <*> optional (textOption @@ -474,20 +478,18 @@ ghciOptsParser = GhciOpts help "Specify which target should contain the main \ \module to load, such as for an executable for \ \test suite or benchmark.")) + <*> buildOptsParser Build -- | Parser for exec command execOptsParser :: Maybe SpecialExecCmd -> Parser ExecOpts execOptsParser mcmd = ExecOpts - <$> pure mcmd + <$> maybe eoCmdParser pure mcmd <*> eoArgsParser <*> execOptsExtraParser where - eoArgsParser :: Parser [String] - eoArgsParser = many (strArgument (metavar meta)) - where - meta = (maybe ("CMD ") (const "") mcmd) ++ - "-- ARGS (e.g. stack ghc -- X.hs -o x)" + eoCmdParser = ExecCmd <$> strArgument (metavar "CMD") + eoArgsParser = many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)")) evalOptsParser :: String -- ^ metavar -> Parser EvalOpts @@ -527,28 +529,39 @@ execOptsExtraParser = eoPlainParser <|> (long "plain" <> help "Use an unmodified environment (only useful with Docker)") - -- | Parser for global command-line options. -globalOptsParser :: Bool -> Parser GlobalOpts -globalOptsParser defaultTerminal = - GlobalOpts <$> +globalOptsParser :: Bool -> Parser GlobalOptsMonoid +globalOptsParser hide0 = + GlobalOptsMonoid <$> optional (strOption (long Docker.reExecArgName <> hidden <> - internal)) <*> - logLevelOptsParser <*> - configOptsParser False <*> - optional abstractResolverOptsParser <*> - optional compilerOptsParser <*> - flag - defaultTerminal - False - (long "no-terminal" <> - help - "Override terminal detection in the case of running in a false terminal") <*> + internal <> + hide)) <*> + logLevelOptsParser hide0 <*> + configOptsParser hide0 <*> + optional (abstractResolverOptsParser hide0) <*> + optional (compilerOptsParser hide0) <*> + maybeBoolFlags + "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)"))) + "(overrides any STACK_YAML environment variable)") <> + hide)) + where hide = hideMods hide0 + +-- | Create GlobalOpts from GlobalOptsMonoid. +globalOptsFromMonoid :: Bool -> GlobalOptsMonoid -> GlobalOpts +globalOptsFromMonoid defaultTerminal gm = GlobalOpts + { globalReExecVersion = globalMonoidReExecVersion gm + , globalLogLevel = fromMaybe defaultLogLevel (globalMonoidLogLevel gm) + , globalConfigMonoid = globalMonoidConfigMonoid gm + , globalResolver = globalMonoidResolver gm + , globalCompiler = globalMonoidCompiler gm + , globalTerminal = fromMaybe defaultTerminal (globalMonoidTerminal gm) + , globalStackYaml = globalMonoidStackYaml gm } initOptsParser :: Parser InitOpts initOptsParser = @@ -582,16 +595,18 @@ initOptsParser = help "Use the given resolver, even if not all dependencies are met") -- | Parse for a logging level. -logLevelOptsParser :: Parser LogLevel -logLevelOptsParser = - fmap parse +logLevelOptsParser :: Bool -> Parser (Maybe LogLevel) +logLevelOptsParser hide = + fmap (Just . parse) (strOption (long "verbosity" <> metavar "VERBOSITY" <> - help "Verbosity: silent, error, warn, info, debug")) <|> - flag defaultLogLevel - verboseLevel + help "Verbosity: silent, error, warn, info, debug" <> + hideMods hide)) <|> + flag' (Just verboseLevel) (short 'v' <> long "verbose" <> - help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\"")) + help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\"") <> + hideMods hide) <|> + pure Nothing where verboseLevel = LevelDebug showLevel l = case l of @@ -609,12 +624,13 @@ logLevelOptsParser = _ -> LevelOther (T.pack s) -- | Parser for the resolver -abstractResolverOptsParser :: Parser AbstractResolver -abstractResolverOptsParser = +abstractResolverOptsParser :: Bool -> Parser AbstractResolver +abstractResolverOptsParser hide = option readAbstractResolver (long "resolver" <> metavar "RESOLVER" <> - help "Override resolver in project file") + help "Override resolver in project file" <> + hideMods hide) readAbstractResolver :: ReadM AbstractResolver readAbstractResolver = do @@ -630,12 +646,13 @@ readAbstractResolver = do Left e -> readerError $ show e Right x -> return $ ARResolver x -compilerOptsParser :: Parser CompilerVersion -compilerOptsParser = +compilerOptsParser :: Bool -> Parser CompilerVersion +compilerOptsParser hide = option readCompilerVersion (long "compiler" <> metavar "COMPILER" <> - help "Use the specified compiler") + help "Use the specified compiler" <> + hideMods hide) readCompilerVersion :: ReadM CompilerVersion readCompilerVersion = do @@ -645,13 +662,15 @@ readCompilerVersion = do Just x -> return x -- | GHC variant parser -ghcVariantParser :: Parser GHCVariant -ghcVariantParser = +ghcVariantParser :: Bool -> Parser GHCVariant +ghcVariantParser hide = option readGHCVariant (long "ghc-variant" <> metavar "VARIANT" <> help - "Specialized GHC variant, e.g. integersimple (implies --no-system-ghc)") + "Specialized GHC variant, e.g. integersimple (implies --no-system-ghc)" <> + hideMods hide + ) where readGHCVariant = do s <- readerAsk @@ -704,13 +723,12 @@ newOptsParser = (,) <$> newOpts <*> initOptsParser (templateParamArgument (short 'p' <> long "param" <> metavar "KEY:VALUE" <> help - "Parameter for the template in the format key:value"))) <* - abortOption ShowHelpText (long "help" <> help "Show help text.") + "Parameter for the template in the format key:value"))) -- | Parser for @stack hpc report@. hpcReportOptsParser :: Parser HpcReportOpts hpcReportOptsParser = HpcReportOpts - <$> (many $ textArgument $ metavar "TARGET_OR_TIX") + <$> many (textArgument $ metavar "TARGET_OR_TIX") <*> switch (long "all" <> help "Use results from all packages and components") <*> optional (strOption (long "destdir" <> help "Output directy for HTML report")) @@ -740,7 +758,7 @@ configCmdSetParser = oneM (fieldToValParser field)) where fieldToValParser :: String -> Parser ConfigCmdSet - fieldToValParser s = do + fieldToValParser s = case s of "resolver" -> ConfigCmdSetResolver <$> @@ -749,3 +767,7 @@ configCmdSetParser = idm _ -> error "parse stack config set field: only set resolver is implemented" + +-- | If argument is True, hides the option from usage and help +hideMods :: Bool -> Mod f a +hideMods hide = if hide then internal <> hidden else idm diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index fca1be5d40..7b641365b7 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -36,6 +36,7 @@ module Stack.Package ,printCabalFileWarning) where +import Control.Arrow ((&&&)) import Control.Exception hiding (try,catch) import Control.Monad import Control.Monad.Catch @@ -186,21 +187,21 @@ resolvePackage packageConfig gpkg = , packageFlags = packageConfigFlags packageConfig , packageAllDeps = S.fromList (M.keys deps) , packageHasLibrary = maybe False (buildable . libBuildInfo) (library pkg) - , packageTests = S.fromList $ + , packageTests = S.fromList [T.pack (testName t) | t <- testSuites pkg , buildable (testBuildInfo t)] - , packageBenchmarks = S.fromList $ + , packageBenchmarks = S.fromList [T.pack (benchmarkName b) | b <- benchmarks pkg , buildable (benchmarkBuildInfo b)] - , packageExes = S.fromList $ + , packageExes = S.fromList [T.pack (exeName b) | b <- executables pkg , buildable (buildInfo b)] , packageOpts = GetPackageOpts $ \sourceMap installedMap omitPkgs cabalfp -> do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp - (componentsOpts,generalOpts) <- + componentsOpts <- generatePkgDescOpts sourceMap installedMap omitPkgs cabalfp pkg componentFiles - return (componentsModules,componentFiles,componentsOpts,generalOpts) + return (componentsModules,componentFiles,componentsOpts) , packageHasExposedModules = maybe False (not . null . exposedModules) @@ -234,7 +235,7 @@ generatePkgDescOpts -> Path Abs File -> PackageDescription -> Map NamedComponent (Set DotCabalPath) - -> m (Map NamedComponent [String],[String]) + -> m (Map NamedComponent BuildInfoOpts) generatePkgDescOpts sourceMap installedMap omitPkgs cabalfp pkg componentPaths = do distDir <- distDirFromDir cabalDir let cabalmacros = autogenDir distDir $(mkRelFile "cabal_macros.h") @@ -262,25 +263,24 @@ generatePkgDescOpts sourceMap installedMap omitPkgs cabalfp pkg componentPaths = [] (return . generate CLib . libBuildInfo) (library pkg) - , map + , fmap (\exe -> - (generate + generate (CExe (T.pack (exeName exe))) - (buildInfo exe))) + (buildInfo exe)) (executables pkg) - , map + , fmap (\bench -> - (generate + generate (CBench (T.pack (benchmarkName bench))) - (benchmarkBuildInfo bench))) + (benchmarkBuildInfo bench)) (benchmarks pkg) - , map + , fmap (\test -> - (generate + generate (CTest (T.pack (testName test))) - (testBuildInfo test))) - (testSuites pkg)]) - , ["-hide-all-packages"]) + (testBuildInfo test)) + (testSuites pkg)])) where cabalDir = parent cabalfp @@ -295,9 +295,21 @@ generateBuildInfoOpts -> BuildInfo -> Set DotCabalPath -> NamedComponent - -> [String] + -> BuildInfoOpts generateBuildInfoOpts sourceMap installedMap mcabalmacros cabalDir distDir omitPkgs b dotCabalPaths componentName = - nubOrd (concat [ghcOpts b, extOpts b, srcOpts, includeOpts, macros, deps, extra b, extraDirs, fworks b, cObjectFiles]) + BuildInfoOpts + { bioGhcOpts = ghcOpts b + -- 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- + -- is", "Bar.hs"] would potentially break due to the duplicate + -- "--main-is" being removed. + -- + -- See https://github.com/commercialhaskell/stack/issues/1255 + , bioGeneratedOpts = nubOrd $ concat + [extOpts b, srcOpts, includeOpts, macros, deps, extra b, extraDirs, fworks b, cObjectFiles] + , bioBuildable = buildable b + } where cObjectFiles = mapMaybe (fmap toFilePath . @@ -313,7 +325,7 @@ generateBuildInfoOpts sourceMap installedMap mcabalmacros cabalDir distDir omitP ((("-" <>) . versionString) . sourceVersion) (M.lookup (fromCabalPackageName name) sourceMap)] | Dependency name _ <- targetBuildDepends b - , not (elem name (map toCabalPackageName omitPkgs))] + , name `notElem` fmap toCabalPackageName omitPkgs] -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ... sourceVersion (PSUpstream ver _ _) = ver sourceVersion (PSLocal localPkg) = packageVersion (lpPackage localPkg) @@ -328,15 +340,14 @@ generateBuildInfoOpts sourceMap installedMap mcabalmacros cabalDir distDir omitP isGhc _ = False extOpts = map (("-X" ++) . display) . usedExtensions srcOpts = - -- This initial "-i" resets the include directories to not - -- include CWD. - "-i" : map - (("-i" <>) . toFilePath) - ((if null (hsSourceDirs b) then [cabalDir] else []) <> - map (cabalDir ) (mapMaybe parseRelDir (hsSourceDirs b)) <> + (("-i" <>) . FilePath.dropTrailingPathSeparator . toFilePath) + ([cabalDir | null (hsSourceDirs b)] <> + mapMaybe toIncludeDir (hsSourceDirs b) <> [autogenDir distDir,buildDir distDir]) ++ - ["-stubdir=" ++ toFilePath (buildDir distDir)] + ["-stubdir=" ++ FilePath.dropTrailingPathSeparator (toFilePath $ buildDir distDir)] + toIncludeDir "." = Just cabalDir + toIncludeDir x = fmap (cabalDir ) (parseRelDir x) includeOpts = [ "-I" <> toFilePath absDir | dir <- includeDirs b @@ -425,7 +436,7 @@ getBuildComponentDir (Just name) = parseRelDir (name FilePath. (name ++ "-tmp packageDependencies :: PackageDescription -> Map PackageName VersionRange packageDependencies = M.fromListWith intersectVersionRanges . - concatMap (map (\dep -> ((depName dep),depRange dep)) . + concatMap (fmap (depName &&& depRange) . targetBuildDepends) . allBuildInfo' @@ -433,7 +444,7 @@ packageDependencies = packageToolDependencies :: PackageDescription -> Map BS.ByteString VersionRange packageToolDependencies = M.fromList . - concatMap (map (\dep -> ((packageNameByteString $ depName dep),depRange dep)) . + concatMap (fmap (packageNameByteString . depName &&& depRange) . buildTools) . allBuildInfo' @@ -512,7 +523,7 @@ resolveGlobFiles = mapM resolve where resolve name = - if any (== '*') name + if '*' `elem` name then explode name else liftM return (resolveFileOrWarn name) explode name = do @@ -650,7 +661,7 @@ libraryFiles lib = do cfiles <- buildOtherSources build return (modules, files <> cfiles, warnings) where - names = concat [bnames, exposed] + names = bnames ++ exposed exposed = map DotCabalModule (exposedModules lib) bnames = map DotCabalModule (otherModules build) build = libBuildInfo lib @@ -703,8 +714,7 @@ resolvePackageDescription packageConfig (GenericPackageDescription desc defaultF updateLibDeps lib deps = lib {libBuildInfo = - ((libBuildInfo lib) {targetBuildDepends = - deps})} + (libBuildInfo lib) {targetBuildDepends = deps}} updateExeDeps exe deps = exe {buildInfo = (buildInfo exe) {targetBuildDepends = deps}} @@ -754,7 +764,7 @@ resolveConditions rc addDeps (CondNode lib deps cs) = basic <> children where basic = addDeps lib deps children = mconcat (map apply cs) where apply (cond,node,mcs) = - if (condSatisfied cond) + if condSatisfied cond then resolveConditions rc addDeps node else maybe mempty (resolveConditions rc addDeps) mcs condSatisfied c = @@ -764,21 +774,18 @@ resolveConditions rc addDeps (CondNode lib deps cs) = basic <> children CNot c' -> not (condSatisfied c') COr cx cy -> - or [condSatisfied cx,condSatisfied cy] + condSatisfied cx || condSatisfied cy CAnd cx cy -> - and [condSatisfied cx,condSatisfied cy] + condSatisfied cx && condSatisfied cy varSatisifed v = case v of OS os -> os == rcOS rc Arch arch -> arch == rcArch rc Flag flag -> - case M.lookup (fromCabalFlagName flag) (rcFlags rc) of - Just x -> x - Nothing -> - -- NOTE: This should never happen, as all flags - -- which are used must be declared. Defaulting - -- to False - False + fromMaybe False $ M.lookup (fromCabalFlagName flag) (rcFlags rc) + -- NOTE: ^^^^^ This should never happen, as all flags + -- which are used must be declared. Defaulting to + -- False. Impl flavor range -> case (flavor, rcCompilerVersion rc) of (GHC, GhcVersion vghc) -> vghc `withinRange` range @@ -793,11 +800,11 @@ resolveConditions rc addDeps (CondNode lib deps cs) = basic <> children -- | Get the name of a dependency. depName :: Dependency -> PackageName -depName = \(Dependency n _) -> fromCabalPackageName n +depName (Dependency n _) = fromCabalPackageName n -- | Get the version range of a dependency. depRange :: Dependency -> VersionRange -depRange = \(Dependency _ r) -> r +depRange (Dependency _ r) = r -- | Try to resolve the list of base names in the given directory by -- looking for unique instances of base names applied with the given @@ -805,10 +812,10 @@ depRange = \(Dependency _ r) -> r -- dependencies. resolveFilesAndDeps :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) - => Maybe (String) -- ^ Package component name - -> [Path Abs Dir] -- ^ Directories to look in. + => Maybe String -- ^ Package component name + -> [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. - -> [Text] -- ^ Extentions. + -> [Text] -- ^ Extentions. -> m (Set ModuleName,Set DotCabalPath,[PackageWarning]) resolveFilesAndDeps component dirs names0 exts = do (dotCabalPaths,foundModules) <- loop names0 S.empty @@ -837,7 +844,7 @@ resolveFilesAndDeps component dirs names0 exts = do warnUnlisted foundModules = do let unlistedModules = foundModules `S.difference` - (S.fromList $ mapMaybe dotCabalModule names0) + S.fromList (mapMaybe dotCabalModule names0) cabalfp <- asks fst return $ if S.null unlistedModules @@ -917,8 +924,8 @@ resolveFiles -> [DotCabalDescriptor] -- ^ Base names. -> [Text] -- ^ Extentions. -> m [DotCabalPath] -resolveFiles dirs names exts = do - liftM catMaybes (forM names (findCandidate dirs exts)) +resolveFiles dirs names exts = + forMaybeM names (findCandidate dirs exts) -- | Find a candidate for the given module-or-filename from the list -- of directories and given extensions. @@ -936,8 +943,7 @@ findCandidate dirs exts name = do [] -> do case name of DotCabalModule mn - | not (display mn == paths_pkg pkg) -> do - logPossibilities dirs mn + | display mn /= paths_pkg pkg -> logPossibilities dirs mn _ -> return () return Nothing (candidate:rest) -> do @@ -962,12 +968,10 @@ findCandidate dirs exts name = do DotCabalCFile fp -> liftM return (try (resolveFile' dir fp)) DotCabalModule mn -> mapM - (\ext -> - try - (resolveFile' - dir - (Cabal.toFilePath mn ++ "." ++ ext))) - (map T.unpack exts) + ((\ ext -> + try (resolveFile' dir (Cabal.toFilePath mn ++ "." ++ ext))) + . T.unpack) + exts resolveFile' :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath.FilePath -> m (Path Abs File) @@ -1057,8 +1061,8 @@ buildLogPath package' msuffix = do env <- ask let stack = configProjectWorkDir env fp <- parseRelFile $ concat $ - (packageIdentifierString (packageIdentifier package')) : - (maybe id (\suffix -> ("-" :) . (suffix :)) msuffix) [".log"] + packageIdentifierString (packageIdentifier package') : + maybe id (\suffix -> ("-" :) . (suffix :)) msuffix [".log"] return $ stack $(mkRelDir "logs") fp -- Internal helper to define resolveFileOrWarn and resolveDirOrWarn diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 325281897c..89fb4ba23f 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} @@ -47,6 +46,7 @@ import Data.IORef import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (catMaybes, listToMaybe) +import Data.Maybe.Extra (mapMaybeM) import qualified Data.Set as Set import qualified Data.Text.Encoding as T import Data.Typeable (Typeable) @@ -108,10 +108,9 @@ ghcPkgCmdArgs -> m a ghcPkgCmdArgs cmd menv wc mpkgDbs sink = do case reverse mpkgDbs of - (pkgDb:_) -> (createDatabase menv wc) pkgDb -- TODO maybe use some retry logic instead? + (pkgDb:_) -> createDatabase menv wc pkgDb -- TODO maybe use some retry logic instead? _ -> return () - a <- sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink - return a + sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink where args = concat [ case mpkgDbs of @@ -129,14 +128,14 @@ newInstalledCache = liftIO $ InstalledCache <$> newIORef (InstalledCacheInner Ma -- empty cache. loadInstalledCache :: (MonadLogger m, MonadIO m) => Path Abs File -> m InstalledCache loadInstalledCache path = do - m <- taggedDecodeOrLoad (toFilePath path) (return $ InstalledCacheInner Map.empty) - liftIO $ fmap InstalledCache $ newIORef m + m <- taggedDecodeOrLoad path (return $ InstalledCacheInner Map.empty) + liftIO $ InstalledCache <$> newIORef m -- | Save a @InstalledCache@ to disk saveInstalledCache :: MonadIO m => Path Abs File -> InstalledCache -> m () saveInstalledCache path (InstalledCache ref) = liftIO $ do createTree (parent path) - readIORef ref >>= taggedEncodeFile (toFilePath path) + readIORef ref >>= taggedEncodeFile path -- | Prune a list of possible packages down to those whose dependencies are met. -- @@ -153,7 +152,7 @@ pruneDeps -> Map name item pruneDeps getName getId getDepends chooseBest = Map.fromList - . (map $ \item -> (getName $ getId item, item)) + . fmap (getName . getId &&& id) . loop Set.empty Set.empty [] where loop foundIds usedNames foundItems dps = @@ -307,10 +306,7 @@ conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do _ -> throwM $ MissingSingleField k m -- Can't fail: if not found, same as an empty list. See: -- https://github.com/fpco/stack/issues/182 - parseM k = - case Map.lookup k m of - Just vs -> vs - Nothing -> [] + parseM k = Map.findWithDefault [] k m parseDepend :: MonadThrow m => ByteString -> m (Maybe GhcPkgId) parseDepend "builtin_rts" = return Nothing @@ -336,7 +332,7 @@ conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do libraries = parseM "hs-libraries" exposedModules = parseM "exposed-modules" exposed = parseM "exposed" - depends <- mapM parseDepend $ parseM "depends" + depends <- mapMaybeM parseDepend $ parseM "depends" let parseQuoted key = case mapM (P.parseOnly (argsParser NoEscaping) . T.decodeUtf8) val of @@ -354,7 +350,7 @@ conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do , dpLibDirs = libDirPaths , dpLibraries = S8.words $ S8.unwords libraries , dpHasExposedModules = not (null libraries || null exposedModules) - , dpDepends = catMaybes (depends :: [Maybe GhcPkgId]) + , dpDepends = depends , dpHaddockInterfaces = haddockInterfaces , dpHaddockHtml = listToMaybe haddockHtml , dpProfiling = () diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index d52e09740b..02bc8caad3 100644 --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -17,15 +17,13 @@ -- | Dealing with the 00-index file and all its cabal files. module Stack.PackageIndex ( updateAllIndices - , PackageDownload (..) - , PackageCache (..) , getPackageCaches ) where import qualified Codec.Archive.Tar as Tar import Control.Exception (Exception) import Control.Exception.Enclosed (tryIO) -import Control.Monad (unless, when, liftM, mzero) +import Control.Monad (unless, when, liftM) import Control.Monad.Catch (MonadThrow, throwM, MonadCatch) import qualified Control.Monad.Catch as C import Control.Monad.IO.Class (MonadIO, liftIO) @@ -35,9 +33,7 @@ import Control.Monad.Reader (asks) import Control.Monad.Trans.Control import Data.Aeson.Extended -import qualified Data.Binary as Binary import Data.Binary.VersionTagged -import Data.ByteString (ByteString) import qualified Data.Word8 as Word8 import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as SU @@ -55,18 +51,10 @@ import Data.Monoid import Data.Text (Text) import qualified Data.Text as T - -import Data.Text.Encoding (encodeUtf8) - import Data.Traversable (forM) import Data.Typeable (Typeable) -import Data.Word (Word64) - - - -import GHC.Generics (Generic) import Network.HTTP.Download import Path (mkRelDir, parent, @@ -81,24 +69,6 @@ import System.IO (IOMode (ReadMode, WriteM withBinaryFile) import System.Process.Read (readInNull, EnvOverride, doesExecutableExist) -data PackageCache = PackageCache - { pcOffset :: !Int64 - -- ^ offset in bytes into the 00-index.tar file for the .cabal file contents - , pcSize :: !Int64 - -- ^ size in bytes of the .cabal file - , pcDownload :: !(Maybe PackageDownload) - } - deriving (Generic) - -instance Binary PackageCache -instance NFData PackageCache -instance HasStructuralInfo PackageCache - -newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache) - deriving (Generic, Binary, NFData) -instance HasStructuralInfo PackageCacheMap -instance HasSemanticVersion PackageCacheMap - -- | Populate the package index caches and return them. populateCache :: (MonadIO m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m) @@ -244,7 +214,7 @@ updateIndex menv index = (True, ILGitHttp url _) -> logUpdate url >> updateIndexGit menv name index url (_, ILHttp url) -> logUpdate url >> updateIndexHTTP name index url (False, ILGitHttp _ url) -> logUpdate url >> updateIndexHTTP name index url - (False, ILGit url) -> logUpdate url >> (throwM $ GitNotAvailable name) + (False, ILGit url) -> logUpdate url >> throwM (GitNotAvailable name) -- | Update the index Git repo and the index tarball updateIndexGit :: (MonadIO m,MonadLogger m,MonadThrow m,MonadReader env m,HasConfig env,MonadBaseControl IO m, MonadCatch m) @@ -280,15 +250,15 @@ updateIndexGit menv indexName' index gitUrl = do $logStickyDone "Fetched package index." removeFileIfExists tarFile when (indexGpgVerify index) - (do readInNull acfDir - "git" - menv - ["tag","-v","current-hackage"] - (Just (T.unlines ["Signature verification failed. " - ,"Please ensure you've set up your" - ,"GPG keychain to accept the D6CF60FD signing key." - ,"For more information, see:" - ,"https://github.com/fpco/stackage-update#readme"]))) + (readInNull acfDir + "git" + menv + ["tag","-v","current-hackage"] + (Just (T.unlines ["Signature verification failed. " + ,"Please ensure you've set up your" + ,"GPG keychain to accept the D6CF60FD signing key." + ,"For more information, see:" + ,"https://github.com/fpco/stackage-update#readme"]))) $logDebug ("Exporting a tarball to " <> (T.pack . toFilePath) tarFile) deleteCache indexName' @@ -357,31 +327,6 @@ deleteCache indexName' = do Left e -> $logDebug $ "Could not delete cache: " <> T.pack (show e) Right () -> $logDebug $ "Deleted index cache at " <> T.pack (toFilePath fp) -data PackageDownload = PackageDownload - { pdSHA512 :: !ByteString - , pdUrl :: !ByteString - , pdSize :: !Word64 - } - deriving (Show, Generic) -instance Binary.Binary PackageDownload -instance HasStructuralInfo PackageDownload -instance NFData PackageDownload -instance FromJSON PackageDownload where - parseJSON = withObject "Package" $ \o -> do - hashes <- o .: "package-hashes" - sha512 <- maybe mzero return (Map.lookup ("SHA512" :: Text) hashes) - locs <- o .: "package-locations" - url <- - case reverse locs of - [] -> mzero - x:_ -> return x - size <- o .: "package-size" - return PackageDownload - { pdSHA512 = encodeUtf8 sha512 - , pdUrl = encodeUtf8 url - , pdSize = size - } - -- | Load the cached package URLs, or created the cache if necessary. getPackageCaches :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m) => EnvOverride @@ -389,7 +334,7 @@ getPackageCaches :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, getPackageCaches menv = do config <- askConfig liftM mconcat $ forM (configPackageIndices config) $ \index -> do - fp <- liftM toFilePath $ configPackageIndexCache (indexName index) + fp <- configPackageIndexCache (indexName index) PackageCacheMap pis' <- taggedDecodeOrLoad fp $ liftM PackageCacheMap $ populateCache menv index return (fmap (index,) pis') diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index fee3859bdf..2975067acb 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -14,7 +14,7 @@ import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Compression.GZip as GZip import Control.Applicative import Control.Concurrent.Execute (ActionContext(..)) -import Control.Monad (when, void) +import Control.Monad (unless, void) import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class import Control.Monad.Logger @@ -171,7 +171,7 @@ readLocalPackage pkgDir = do mapM_ (printCabalFileWarning cabalfp) warnings return LocalPackage { lpPackage = package - , lpExeComponents = Nothing -- HACK: makes it so that sdist output goes to a log instead of a file. + , lpWanted = False -- HACK: makes it so that sdist output goes to a log instead of a file. , lpDir = pkgDir , lpCabalFile = cabalfp -- NOTE: these aren't the 'correct values, but aren't used in @@ -196,7 +196,7 @@ getSDistFileList lp = runInBase <- liftBaseWith $ \run -> return (void . run) withExecuteEnv menv bopts baseConfigOpts locals [] [] [] -- provide empty list of globals. This is a hack around custom Setup.hs files - sourceMap $ \ee -> do + sourceMap $ \ee -> withSingleContext runInBase ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do let outFile = toFilePath tmpdir FP. "source-files-list" cabal False ["sdist", "--list-sources", outFile] @@ -213,13 +213,14 @@ getSDistFileList lp = , tcoOpts = \_ -> ConfigureOpts [] [] } , taskPresent = Map.empty + , taskAllInOne = True } normalizeTarballPaths :: M env m => [FilePath] -> m [FilePath] normalizeTarballPaths fps = do --TODO: consider whether erroring out is better - otherwise the --user might upload an incomplete tar? - when (not (null outsideDir)) $ + unless (null outsideDir) $ $logWarn $ T.concat [ "Warning: These files are outside of the package directory, and will be omitted from the tarball: " , T.pack (show outsideDir)] @@ -228,7 +229,7 @@ normalizeTarballPaths fps = do (outsideDir, files) = partitionEithers (map pathToEither fps) pathToEither fp = maybe (Left fp) Right (normalizePath fp) -normalizePath :: FilePath -> (Maybe FilePath) +normalizePath :: FilePath -> Maybe FilePath normalizePath = fmap FP.joinPath . go . FP.splitDirectories . FP.normalise where go [] = Just [] diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index e14fb7f5f8..70f20384ce 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -42,7 +42,7 @@ import Data.Either import Data.Foldable hiding (concatMap, or, maximum) import Data.IORef import Data.IORef.RunOnce (runOnce) -import Data.List hiding (concat, elem, maximumBy) +import Data.List hiding (concat, elem, maximumBy, any) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe @@ -67,7 +67,7 @@ import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO import qualified Paths_stack as Meta -import Prelude hiding (concat, elem) -- Fix AMP warning +import Prelude hiding (concat, elem, any) -- Fix AMP warning import Safe (readMay) import Stack.Build (build) import Stack.Config (resolvePackageEntry, loadConfig) @@ -282,9 +282,8 @@ setupEnv mResolveMissingGHC = do [ toFilePathNoTrailingSep deps , "" ]) - $ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSep distDir) - $ env - !() <- atomicModifyIORef envRef $ \m' -> + $ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSep distDir) env + () <- atomicModifyIORef envRef $ \m' -> (Map.insert es eo m', ()) return eo @@ -340,7 +339,8 @@ ensureCompiler sopts = do arch /= expectedArch isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts) - -- If we need to install a GHC, try to do so + -- If we need to install a GHC or MSYS, try to do so + -- Return the additional directory paths of GHC & MSYS. mtools <- if needLocal then do getSetupInfo' <- runOnce (getSetupInfo (soptsStackSetupYaml sopts) =<< asks getHttpManager) @@ -366,7 +366,7 @@ ensureCompiler sopts = do (soptsWantedCompiler sopts) (soptsCompilerCheck sopts) (soptsGHCBindistURL sopts) - | otherwise -> do + | otherwise -> throwM $ CompilerVersionMismatch msystem (soptsWantedCompiler sopts, expectedArch) @@ -405,6 +405,7 @@ ensureCompiler sopts = do mpaths <- case mtools of Nothing -> return Nothing Just (compilerTool, mmsys2Tool) -> do + -- Add GHC's and MSYS's paths to the config. let idents = catMaybes [Just compilerTool, mmsys2Tool] paths <- mapM extraDirs idents return $ Just $ mconcat paths @@ -506,7 +507,7 @@ upgradeCabal menv wc = do dir <- case Map.lookup ident m of - Nothing -> error $ "upgradeCabal: Invariant violated, dir missing" + Nothing -> error "upgradeCabal: Invariant violated, dir missing" Just dir -> return dir runIn dir (compilerExeName wc) menv ["Setup.hs"] Nothing @@ -635,7 +636,7 @@ downloadAndInstallCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReade => SetupInfo -> CompilerVersion -> VersionCheck - -> (Maybe String) + -> Maybe String -> m Tool downloadAndInstallCompiler si wanted@(GhcVersion{}) versionCheck mbindistURL = do ghcVariant <- asks getGHCVariant @@ -669,7 +670,7 @@ downloadAndInstallCompiler si wanted@(GhcVersion{}) versionCheck mbindistURL = d ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant) let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer -downloadAndInstallCompiler si wanted@(GhcjsVersion version _) versionCheck _mbindistUrl = do +downloadAndInstallCompiler si wanted versionCheck _mbindistUrl = do config <- asks getConfig ghcVariant <- asks getGHCVariant case ghcVariant of @@ -680,7 +681,11 @@ downloadAndInstallCompiler si wanted@(GhcjsVersion version _) versionCheck _mbin Just pairs -> getWantedCompilerInfo "source" versionCheck wanted id pairs $logInfo "Preparing to install GHCJS to an isolated location." $logInfo "This will not interfere with any system-level installation." - downloadAndInstallTool (configLocalPrograms config) si downloadInfo (ToolGhcjs selectedVersion) (installGHCJS version) + let tool = ToolGhcjs selectedVersion + installer = installGHCJS $ case selectedVersion of + GhcjsVersion version _ -> version + _ -> error "Invariant violated: expected ghcjs version in downloadAndInstallCompiler." + downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer getWantedCompilerInfo :: (Ord k, MonadThrow m) => Text @@ -689,7 +694,7 @@ getWantedCompilerInfo :: (Ord k, MonadThrow m) -> (k -> CompilerVersion) -> Map k a -> m (k, a) -getWantedCompilerInfo key versionCheck wanted toCV pairs = do +getWantedCompilerInfo key versionCheck wanted toCV pairs = case mpair of Just pair -> return pair Nothing -> throwM $ UnknownCompilerVersion key wanted (map toCV (Map.keys pairs)) @@ -709,7 +714,7 @@ getGhcKey = do getOSKey :: (MonadReader env m, MonadThrow m, HasPlatform env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) => Platform -> m Text -getOSKey platform = do +getOSKey platform = case platform of Platform I386 Cabal.Linux -> return "linux32" Platform X86_64 Cabal.Linux -> return "linux64" @@ -788,7 +793,7 @@ installGHCPosix version _ archiveFile archiveType destDir = do parseRelDir $ "ghc-" ++ versionString version - $logSticky $ T.concat ["Unpacking GHC into ", (T.pack . toFilePath $ root), " ..."] + $logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ root, " ..."] $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) readInNull root tarTool menv ["xf", toFilePath archiveFile] Nothing @@ -832,7 +837,7 @@ installGHCJS version si archiveFile archiveType destDir = do let unpackDir = destDir Path. $(mkRelDir "src") tarComponent <- parseRelDir ("ghcjs-" ++ versionString version) runUnpack <- case platform of - Platform _ Cabal.Windows -> return $ do + Platform _ Cabal.Windows -> return $ withUnpackedTarball7z "GHCJS" si archiveFile archiveType tarComponent unpackDir _ -> do zipTool' <- @@ -851,7 +856,7 @@ installGHCJS version si archiveFile archiveType destDir = do readInNull destDir tarTool menv ["xf", toFilePath archiveFile] Nothing renameDir (destDir Path. tarComponent) unpackDir - $logSticky $ T.concat ["Unpacking GHCJS into ", (T.pack . toFilePath $ unpackDir), " ..."] + $logSticky $ T.concat ["Unpacking GHCJS into ", T.pack . toFilePath $ unpackDir, " ..."] $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) runUnpack @@ -931,7 +936,7 @@ ensureGhcjsBooted menv cv shouldBoot = do parseRelFile $ "ghcjs-" ++ versionString version ++ "/stack.yaml" _ -> fail "ensureGhcjsBooted invoked on non GhcjsVersion" actualStackYamlExists <- fileExists actualStackYaml - when (not actualStackYamlExists) $ + unless actualStackYamlExists $ fail "Couldn't find GHCJS stack.yaml in old or new location." bootGhcjs actualStackYaml destDir Left err -> throwM err @@ -1101,7 +1106,7 @@ withUnpackedTarball7z name si archiveFile archiveType srcDir destDir = do Nothing -> error $ "Invalid " ++ name ++ " filename: " ++ show archiveFile Just x -> parseAbsFile $ T.unpack x run7z <- setup7z si - let tmpName = (toFilePathNoTrailingSep $ dirname destDir) ++ "-tmp" + let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp" createTree (parent destDir) withCanonicalizedTempDirectory (toFilePath $ parent destDir) tmpName $ \tmpDir -> do let absSrcDir = tmpDir srcDir @@ -1120,7 +1125,7 @@ withUnpackedTarball7z name si archiveFile archiveType srcDir destDir = do -- | Download 7z as necessary, and get a function for unpacking things. -- -- Returned function takes an unpack directory and archive. -setup7z :: (MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m) +setup7z :: (MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadLogger n, MonadBaseControl IO m) => SetupInfo -> m (Path Abs Dir -> Path Abs File -> n ()) setup7z si = do @@ -1131,15 +1136,18 @@ setup7z si = do (Just sevenzDll, Just sevenzExe) -> do chattyDownload "7z.dll" sevenzDll dll chattyDownload "7z.exe" sevenzExe exe - return $ \outdir archive -> liftIO $ do - ec <- rawSystem (toFilePath exe) - [ "x" - , "-o" ++ toFilePath outdir - , "-y" - , toFilePath archive - ] + return $ \outdir archive -> do + let cmd = toFilePath exe + args = + [ "x" + , "-o" ++ toFilePath outdir + , "-y" + , toFilePath archive + ] + $logProcessRun cmd args + ec <- liftIO $ rawSystem cmd args when (ec /= ExitSuccess) - $ throwM (ProblemWhileDecompressing archive) + $ liftIO $ throwM (ProblemWhileDecompressing archive) _ -> throwM SetupInfoMissingSevenz chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m) @@ -1219,7 +1227,7 @@ chattyDownload label downloadInfo path = do (T.unpack label) percentage where percentage :: Double - percentage = (fromIntegral totalSoFar / fromIntegral total * 100) + percentage = fromIntegral totalSoFar / fromIntegral total * 100 -- | Given a printf format string for the decimal part and a number of -- bytes, formats the bytes using an appropiate unit and returns the @@ -1318,10 +1326,7 @@ getUtf8LocaleVars menv = do existingVarNames = Set.unions (map snd checkedVars) -- True if a locale is already specified by one of the "global" locale variables. hasAnyExisting = - or $ - map - (`Set.member` existingVarNames) - ["LANG", "LANGUAGE", "LC_ALL"] + any (`Set.member` existingVarNames) ["LANG", "LANGUAGE", "LC_ALL"] if null needChangeVars && hasAnyExisting then -- If no variables need changes and at least one "global" variable is set, no @@ -1403,7 +1408,7 @@ getUtf8LocaleVars menv = do -- -a@. getFallbackLocale :: [Text] -> Maybe Text - getFallbackLocale utf8Locales = do + getFallbackLocale utf8Locales = case concatMap (matchingLocales utf8Locales) fallbackPrefixes of (v:_) -> Just v [] -> @@ -1414,17 +1419,10 @@ getUtf8LocaleVars menv = do matchingLocales :: [Text] -> Text -> [Text] matchingLocales utf8Locales prefix = - filter - (\v -> - (T.toLower prefix) `T.isPrefixOf` T.toLower v) - utf8Locales + filter (\v -> T.toLower prefix `T.isPrefixOf` T.toLower v) utf8Locales -- Does the locale have one of the encodings in @utf8Suffixes@ (case-insensitive)? isUtf8Locale locale = - or $ - map - (\v -> - T.toLower v `T.isSuffixOf` T.toLower locale) - utf8Suffixes + any (\ v -> T.toLower v `T.isSuffixOf` T.toLower locale) utf8Suffixes -- Prefixes of fallback locales (case-insensitive) fallbackPrefixes = ["C.", "en_US.", "en_"] -- Suffixes of UTF-8 locales (case-insensitive) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 4878d805b5..bf13e5b128 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -47,6 +47,7 @@ cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, Mo -> [String] -- ^ additional arguments -> m (CompilerVersion, Map PackageName (Version, Map FlagName Bool)) cabalSolver wc cabalfps constraints userFlags cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do + when (null cabalfps) $ throwM SolverNoCabalFiles configLines <- getCabalConfig dir constraints let configFile = dir FP. "cabal.config" liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines @@ -99,7 +100,7 @@ cabalSolver wc cabalfps constraints userFlags cabalArgs = withSystemTempDirector : "--package-db=global" : cabalArgs ++ toConstraintArgs userFlags ++ - (map toFilePath cabalfps) ++ + fmap toFilePath cabalfps ++ ["--ghcjs" | wc == Ghcjs] $logInfo "Asking cabal to calculate a build plan, please wait" @@ -178,8 +179,6 @@ solveExtraDeps :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadMask m, => Bool -- ^ modify stack.yaml? -> m () solveExtraDeps modStackYaml = do - $logInfo "This command is not guaranteed to give you a perfect build plan" - $logInfo "It's possible that even with the changes generated below, you will still need to do some manual tweaking" econfig <- asks getEnvConfig bconfig <- asks getBuildConfig snapshot <- @@ -205,11 +204,13 @@ solveExtraDeps modStackYaml = do let newDeps = extraDeps `Map.difference` packages newFlags = Map.filter (not . Map.null) $ fmap snd newDeps + $logInfo "This command is not guaranteed to give you a perfect build plan" if Map.null newDeps then $logInfo "No needed changes found" else do + $logInfo "It's possible that even with the changes generated below, you will still need to do some manual tweaking" let o = object - $ ("extra-deps" .= (map fromTuple $ Map.toList $ fmap fst newDeps)) + $ ("extra-deps" .= map fromTuple (Map.toList $ fmap fst newDeps)) : (if Map.null newFlags then [] else ["flags" .= newFlags]) diff --git a/src/Stack/Types.hs b/src/Stack/Types.hs index 943770b6d9..b83e08441c 100644 --- a/src/Stack/Types.hs +++ b/src/Stack/Types.hs @@ -8,6 +8,7 @@ import Stack.Types.BuildPlan as X import Stack.Types.FlagName as X import Stack.Types.GhcPkgId as X import Stack.Types.PackageIdentifier as X +import Stack.Types.PackageIndex as X import Stack.Types.PackageName as X import Stack.Types.Version as X import Stack.Types.Config as X diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 94c399ff0a..ade753edb2 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -120,6 +120,7 @@ data StackBuildException | DuplicateLocalPackageNames [(PackageName, [Path Abs Dir])] | SolverMissingCabalInstall | SolverMissingGHC + | SolverNoCabalFiles deriving Typeable data FlagSource = FSCommandLine | FSStackYaml @@ -326,6 +327,10 @@ instance Show StackBuildException where [ "Solver requires that GHC be on your PATH" , "Try running 'stack setup'" ] + show SolverNoCabalFiles = unlines + [ "No cabal files provided. Maybe this is due to not having a stack.yaml file?" + , "Try running 'stack init' to create a stack.yaml" + ] instance Exception StackBuildException @@ -405,7 +410,7 @@ data BuildSubset -- ^ Only install packages in the snapshot database, skipping -- packages intended for the local database. | BSOnlyDependencies - deriving Show + deriving (Show, Eq) -- | Configuration for building. data BuildOpts = @@ -554,10 +559,15 @@ instance HasSemanticVersion ConfigCache -- | A task to perform when building data Task = Task - { taskProvides :: !PackageIdentifier -- ^ the package/version to be built - , taskType :: !TaskType -- ^ the task type, telling us how to build this + { taskProvides :: !PackageIdentifier + -- ^ the package/version to be built + , taskType :: !TaskType + -- ^ the task type, telling us how to build this , taskConfigOpts :: !TaskConfigOpts - , taskPresent :: !(Map PackageIdentifier GhcPkgId) -- ^ GhcPkgIds of already-installed dependencies + , taskPresent :: !(Map PackageIdentifier GhcPkgId) + -- ^ GhcPkgIds of already-installed dependencies + , taskAllInOne :: !Bool + -- ^ indicates that the package can be built in one step } deriving Show @@ -591,7 +601,7 @@ taskLocation task = -- | A complete plan of what needs to be built and how to do it data Plan = Plan { planTasks :: !(Map PackageName Task) - , planFinals :: !(Map PackageName (Task, LocalPackageTB)) + , planFinals :: !(Map PackageName Task) -- ^ Final actions to be taken (test, benchmark, etc) , planUnregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Maybe Text)) -- ^ Text is reason we're unregistering, for display only @@ -711,8 +721,8 @@ configureOptsNoDir econfig bco deps wanted isLocal package = concat ghcOptionsMap = configGhcOptions $ getConfig econfig allGhcOptions = concat - [ fromMaybe [] $ Map.lookup Nothing ghcOptionsMap - , fromMaybe [] $ Map.lookup (Just $ packageName package) ghcOptionsMap + [ Map.findWithDefault [] Nothing ghcOptionsMap + , Map.findWithDefault [] (Just $ packageName package) ghcOptionsMap , if includeExtraOptions then boptsGhcOptions bopts else [] diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index 562727f089..63bc6e22a4 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ViewPatterns #-} module Stack.Types.Compiler where diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 9d0ae235e6..9f7c749681 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -13,7 +13,109 @@ -- | The Config type. -module Stack.Types.Config where +module Stack.Types.Config + ( + -- * Main configuration types and classes + -- ** HasPlatform & HasStackRoot + HasPlatform(..) + ,HasStackRoot(..) + -- ** Config & HasConfig + ,Config(..) + ,HasConfig(..) + ,askConfig + ,askLatestSnapshotUrl + ,explicitSetupDeps + ,getMinimalEnvOverride + -- ** BuildConfig & HasBuildConfig + ,BuildConfig(..) + ,bcRoot + ,bcWorkDir + ,HasBuildConfig(..) + -- ** GHCVariant & HasGHCVariant + ,GHCVariant(..) + ,ghcVariantName + ,ghcVariantSuffix + ,parseGHCVariant + ,HasGHCVariant(..) + ,snapshotsDir + -- ** EnvConfig & HasEnvConfig + ,EnvConfig(..) + ,HasEnvConfig(..) + ,getWhichCompiler + -- * Details + -- ** ApplyGhcOptions + ,ApplyGhcOptions(..) + -- ** ConfigException + ,ConfigException(..) + -- ** ConfigMonoid + ,ConfigMonoid(..) + -- ** EnvSettings + ,EnvSettings(..) + ,minimalEnvSettings + -- ** GlobalOpts & GlobalOptsMonoid + ,GlobalOpts(..) + ,GlobalOptsMonoid(..) + ,defaultLogLevel + -- ** LoadConfig + ,LoadConfig(..) + -- ** PackageEntry & PackageLocation + ,PackageEntry(..) + ,peExtraDep + ,PackageLocation(..) + -- ** PackageIndex, IndexName & IndexLocation + ,PackageIndex(..) + ,IndexName(..) + ,configPackageIndex + ,configPackageIndexCache + ,configPackageIndexGz + ,configPackageIndexRoot + ,configPackageTarball + ,indexNameText + ,IndexLocation(..) + -- ** Project & ProjectAndConfigMonoid + ,Project(..) + ,ProjectAndConfigMonoid(..) + -- ** PvpBounds + ,PvpBounds(..) + ,parsePvpBounds + -- ** Resolver & AbstractResolver + ,Resolver(..) + ,parseResolverText + ,resolverName + ,AbstractResolver(..) + -- ** SCM + ,SCM(..) + -- * Paths + ,bindirSuffix + ,configInstalledCache + ,configMiniBuildPlanCache + ,configProjectWorkDir + ,docDirSuffix + ,flagCacheLocal + ,extraBinDirs + ,hpcReportDir + ,installationRootDeps + ,installationRootLocal + ,packageDatabaseDeps + ,packageDatabaseExtra + ,packageDatabaseLocal + ,platformOnlyRelDir + ,platformVariantRelDir + ,useShaPathOnWindows + ,workDirRel + -- * Command-specific types + -- ** Eval + ,EvalOpts(..) + -- ** Exec + ,ExecOpts(..) + ,SpecialExecCmd(..) + ,ExecOptsExtra(..) + -- ** Setup + ,DownloadInfo(..) + ,VersionedDownloadInfo(..) + ,SetupInfo(..) + ,SetupInfoLocation(..) + ) where import Control.Applicative import Control.Arrow ((&&&)) @@ -58,6 +160,7 @@ import Stack.Types.Docker import Stack.Types.FlagName import Stack.Types.Image import Stack.Types.PackageIdentifier +import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.Version import System.Process.Read (EnvOverride) @@ -243,16 +346,14 @@ data EnvSettings = EnvSettings deriving (Show, Eq, Ord) data ExecOpts = ExecOpts - { eoCmd :: !(Maybe SpecialExecCmd) - -- ^ When 'Nothing', then the program to run is the head of - -- 'eoArgs'. See: - -- https://github.com/commercialhaskell/stack/issues/806 + { eoCmd :: !SpecialExecCmd , eoArgs :: ![String] , eoExtra :: !ExecOptsExtra } deriving (Show) data SpecialExecCmd - = ExecGhc + = ExecCmd String + | ExecGhc | ExecRunGhc deriving (Show, Eq) @@ -280,6 +381,28 @@ data GlobalOpts = GlobalOpts , globalStackYaml :: !(Maybe FilePath) -- ^ Override project stack.yaml } deriving (Show) +-- | Parsed global command-line options monoid. +data GlobalOptsMonoid = GlobalOptsMonoid + { globalMonoidReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version + , globalMonoidLogLevel :: !(Maybe 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) + +instance Monoid GlobalOptsMonoid where + mempty = GlobalOptsMonoid Nothing Nothing mempty Nothing Nothing Nothing Nothing + mappend l r = GlobalOptsMonoid + { globalMonoidReExecVersion = globalMonoidReExecVersion l <|> globalMonoidReExecVersion 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 } + -- | Either an actual resolver value, or an abstract description of one (e.g., -- latest nightly). data AbstractResolver @@ -326,15 +449,17 @@ data BuildConfig = BuildConfig -- for providing better error messages. , bcGHCVariant :: !GHCVariant -- ^ The variant of GHC used to select a GHC bindist. + , bcPackageCaches :: !(Map PackageIdentifier (PackageIndex, PackageCache)) + -- ^ Shared package cache map } -- | Directory containing the project's stack.yaml file bcRoot :: BuildConfig -> Path Abs Dir bcRoot = parent . bcStackYaml --- | Directory containing the project's stack.yaml file +-- | @"'bcRoot'/.stack-work"@ bcWorkDir :: BuildConfig -> Path Abs Dir -bcWorkDir = ( workDirRel) . parent . bcStackYaml +bcWorkDir = ( workDirRel) . bcRoot -- | Configuration after the environment has been setup. data EnvConfig = EnvConfig @@ -839,9 +964,6 @@ configMonoidLocalBinPathName = "local-bin-path" configMonoidImageOptsName :: Text configMonoidImageOptsName = "image" -configMonoidTemplatesName :: Text -configMonoidTemplatesName = "templates" - configMonoidScmInitName :: Text configMonoidScmInitName = "scm-init" @@ -878,16 +1000,6 @@ configMonoidApplyGhcOptionsName = "apply-ghc-options" configMonoidAllowNewerName :: Text configMonoidAllowNewerName = "allow-newer" --- | Newtype for non-orphan FromJSON instance. -newtype VersionRangeJSON = VersionRangeJSON { unVersionRangeJSON :: VersionRange } - --- | Parse VersionRange. -instance FromJSON VersionRangeJSON where - parseJSON = withText "VersionRange" - (\s -> maybe (fail ("Invalid cabal-style VersionRange: " ++ T.unpack s)) - (return . VersionRangeJSON) - (Distribution.Text.simpleParse (T.unpack s))) - data ConfigException = ParseConfigFileException (Path Abs File) ParseException | ParseResolverException Text @@ -931,9 +1043,9 @@ instance Show ConfigException where [ "The version of stack you are using (" , show (fromCabalVersion Meta.version) , ") is outside the required\n" - ,"version range (" + ,"version range specified in stack.yaml (" , T.unpack (versionRangeText requiredRange) - , ") specified in stack.yaml." ] + , ")." ] show (NoMatchingSnapshot names) = concat [ "There was no snapshot found that matched the package " , "bounds in your .cabal files.\n" @@ -992,6 +1104,7 @@ configPackageTarball iname ident = do base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz" return (root $(mkRelDir "packages") name ver base) +-- | @".stack-work"@ workDirRel :: Path Rel Dir workDirRel = $(mkRelDir ".stack-work") @@ -1013,14 +1126,6 @@ platformOnlyRelDir = do platform <- asks getPlatform parseRelDir (Distribution.Text.display platform) --- | Path to .shake files. -configShakeFilesDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs Dir) -configShakeFilesDir = liftM ( $(mkRelDir "shake")) configProjectWorkDir - --- | Where to unpack packages for local build -configLocalUnpackDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs Dir) -configLocalUnpackDir = liftM ( $(mkRelDir "unpacked")) configProjectWorkDir - -- | Directory containing snapshots snapshotsDir :: (MonadReader env m, HasConfig env, HasGHCVariant env, MonadThrow m) => m (Path Abs Dir) snapshotsDir = do diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs index 82a1d0559c..ce6933fa01 100644 --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -10,7 +10,11 @@ import Control.Monad.Catch (MonadThrow) import Data.Aeson.Extended import Data.Monoid import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Text (simpleParse) +import Distribution.Version (anyVersion) import Path +import Stack.Types.Version -- | Docker configuration. data DockerOpts = DockerOpts @@ -46,6 +50,8 @@ data DockerOpts = DockerOpts -- ^ Location of container-compatible stack executable ,dockerSetUser :: !(Maybe Bool) -- ^ Set in-container user to match host's + ,dockerRequireDockerVersion :: !VersionRange + -- ^ Require a version of Docker within this range. } deriving (Show) @@ -86,6 +92,8 @@ data DockerOptsMonoid = DockerOptsMonoid -- ^ Location of container-compatible stack executable ,dockerMonoidSetUser :: !(Maybe Bool) -- ^ Set in-container user to match host's + ,dockerMonoidRequireDockerVersion :: !VersionRange + -- ^ See: 'dockerRequireDockerVersion' } deriving (Show) @@ -110,6 +118,10 @@ instance FromJSON (DockerOptsMonoid, [JSONWarning]) where dockerMonoidDatabasePath <- o ..:? dockerDatabasePathArgName dockerMonoidStackExe <- o ..:? dockerStackExeArgName dockerMonoidSetUser <- o ..:? dockerSetUserArgName + dockerMonoidRequireDockerVersion + <- unVersionRangeJSON <$> + o ..:? dockerRequireDockerVersionArgName + ..!= VersionRangeJSON anyVersion return DockerOptsMonoid{..}) -- | Left-biased combine Docker options @@ -131,6 +143,7 @@ instance Monoid DockerOptsMonoid where ,dockerMonoidDatabasePath = Nothing ,dockerMonoidStackExe = Nothing ,dockerMonoidSetUser = Nothing + ,dockerMonoidRequireDockerVersion = anyVersion } mappend l r = DockerOptsMonoid {dockerMonoidDefaultEnable = dockerMonoidDefaultEnable l || dockerMonoidDefaultEnable r @@ -149,6 +162,9 @@ instance Monoid DockerOptsMonoid where ,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r ,dockerMonoidStackExe = dockerMonoidStackExe l <|> dockerMonoidStackExe r ,dockerMonoidSetUser = dockerMonoidSetUser l <|> dockerMonoidSetUser r + ,dockerMonoidRequireDockerVersion + = intersectVersionRanges (dockerMonoidRequireDockerVersion l) + (dockerMonoidRequireDockerVersion r) } -- | Where to get the `stack` executable to run in Docker containers @@ -194,6 +210,16 @@ data DockerMonoidRepoOrImage | DockerMonoidImage String deriving (Show) +-- | Newtype for non-orphan FromJSON instance. +newtype VersionRangeJSON = VersionRangeJSON { unVersionRangeJSON :: VersionRange } + +-- | Parse VersionRange. +instance FromJSON VersionRangeJSON where + parseJSON = withText "VersionRange" + (\s -> maybe (fail ("Invalid cabal-style VersionRange: " ++ T.unpack s)) + (return . VersionRangeJSON) + (Distribution.Text.simpleParse (T.unpack s))) + -- | Docker enable argument name. dockerEnableArgName :: Text dockerEnableArgName = "enable" @@ -269,3 +295,7 @@ dockerStackExeImageVal = "image" -- | Docker @set-user@ argument name dockerSetUserArgName :: Text dockerSetUserArgName = "set-user" + +-- | Docker @require-version@ argument name +dockerRequireDockerVersionArgName :: Text +dockerRequireDockerVersionArgName = "require-docker-version" diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs index f14ce07097..481d98208c 100644 --- a/src/Stack/Types/FlagName.hs +++ b/src/Stack/Types/FlagName.hs @@ -57,7 +57,7 @@ newtype FlagName = deriving (Typeable,Data,Generic,Hashable,Binary,NFData) instance HasStructuralInfo FlagName instance Eq FlagName where - x == y = (compare x y) == EQ + x == y = compare x y == EQ instance Ord FlagName where compare (FlagName x) (FlagName y) = compare (S.map Word8.toLower x) (S.map Word8.toLower y) diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs index e08692f376..e6a923e15e 100644 --- a/src/Stack/Types/GhcPkgId.hs +++ b/src/Stack/Types/GhcPkgId.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 316cc562ab..ea3b333123 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -23,6 +23,7 @@ import Data.Map.Strict (Map) import Data.Maybe import Data.Monoid import Data.Set (Set) +import qualified Data.Set as Set import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Distribution.InstalledPackageInfo (PError) @@ -105,11 +106,22 @@ newtype GetPackageOpts = GetPackageOpts -> Path Abs File -> m (Map NamedComponent (Set ModuleName) ,Map NamedComponent (Set DotCabalPath) - ,Map NamedComponent [String],[String]) + ,Map NamedComponent BuildInfoOpts) } instance Show GetPackageOpts where show _ = "" +data BuildInfoOpts = BuildInfoOpts + { bioGhcOpts :: [String] + -- ^ Options from the ghc-options cabal field + , bioGeneratedOpts :: [String] + -- ^ Other options from cabal information. These options can safely have + -- 'nubOrd' applied to them, as there are no multi-word options (see + -- https://github.com/commercialhaskell/stack/issues/1255) + , bioBuildable :: Bool + -- ^ Whether the cabal component is buildable. + } deriving Show + -- | Files to get for a cabal package. data CabalFileType = AllFiles @@ -137,18 +149,18 @@ instance Show PackageWarning where concat [ "module not listed in " , toFilePath (filename cabalfp) - , (case component of + , case component of Nothing -> " for library" - Just c -> " for '" ++ c ++ "'") + Just c -> " for '" ++ c ++ "'" , " component (add to other-modules): " , display unlistedModule] show (UnlistedModulesWarning cabalfp component unlistedModules) = concat [ "modules not listed in " , toFilePath (filename cabalfp) - , (case component of + , case component of Nothing -> " for library" - Just c -> " for '" ++ c ++ "'") + Just c -> " for '" ++ c ++ "'" , " component (add to other-modules):\n " , intercalate "\n " (map display unlistedModules)] @@ -193,45 +205,38 @@ class PackageInstallInfo a where piiVersion :: a -> Version piiLocation :: a -> InstallLocation --- | Second-stage build information: tests and benchmarks -data LocalPackageTB = LocalPackageTB - { lptbPackage :: !Package - -- ^ Package resolved with dependencies for tests and benchmarks, depending - -- on which components are active - , lptbTests :: !(Set Text) - -- ^ Test components - , lptbBenches :: !(Set Text) - -- ^ Benchmark components - } - deriving Show - -- | Information on a locally available package of source code data LocalPackage = LocalPackage - { lpPackage :: !Package -- ^ The @Package@ info itself, after resolution with package flags, not including any tests or benchmarks - , lpTestDeps :: !(Map PackageName VersionRange) - -- ^ Used for determining if we can use --enable-tests in a normal build - , lpBenchDeps :: !(Map PackageName VersionRange) - -- ^ Used for determining if we can use --enable-benchmarks in a normal build - , lpExeComponents :: !(Maybe (Set Text)) -- ^ Executable components to build, Nothing if not a target - - , lpTestBench :: !(Maybe LocalPackageTB) - - , lpDir :: !(Path Abs Dir) -- ^ Directory of the package. - , lpCabalFile :: !(Path Abs File) -- ^ The .cabal file - , lpDirtyFiles :: !(Maybe (Set FilePath)) + { lpPackage :: !Package + -- ^ The @Package@ info itself, after resolution with package flags, + -- with tests and benchmarks disabled + , lpComponents :: !(Set NamedComponent) + -- ^ Components to build, not including the library component. + , lpWanted :: !Bool + -- ^ Whether this package is wanted as a target. + , lpTestDeps :: !(Map PackageName VersionRange) + -- ^ Used for determining if we can use --enable-tests in a normal build. + , lpBenchDeps :: !(Map PackageName VersionRange) + -- ^ Used for determining if we can use --enable-benchmarks in a normal + -- build. + , lpTestBench :: !(Maybe Package) + -- ^ This stores the 'Package' with tests and benchmarks enabled, if + -- either is asked for by the user. + , lpDir :: !(Path Abs Dir) + -- ^ Directory of the package. + , lpCabalFile :: !(Path Abs File) + -- ^ The .cabal file + , lpDirtyFiles :: !(Maybe (Set FilePath)) -- ^ Nothing == not dirty, Just == dirty. Note that the Set may be empty if -- we forced the build to treat packages as dirty. Also, the Set may not -- include all modified files. - , lpNewBuildCache :: !(Map FilePath FileCacheInfo) -- ^ current state of the files - , lpFiles :: !(Set (Path Abs File)) -- ^ all files used by this package - , lpComponents :: !(Set NamedComponent) + , lpNewBuildCache :: !(Map FilePath FileCacheInfo) + -- ^ current state of the files + , lpFiles :: !(Set (Path Abs File)) + -- ^ all files used by this package } deriving Show --- | Is the given local a target -lpWanted :: LocalPackage -> Bool -lpWanted lp = isJust (lpExeComponents lp) || isJust (lpTestBench lp) - -- | A single, fully resolved component of a package data NamedComponent = CLib @@ -246,6 +251,40 @@ renderComponent (CExe x) = "exe:" <> encodeUtf8 x renderComponent (CTest x) = "test:" <> encodeUtf8 x renderComponent (CBench x) = "bench:" <> encodeUtf8 x +exeComponents :: Set NamedComponent -> Set Text +exeComponents = Set.fromList . mapMaybe mExeName . Set.toList + where + mExeName (CExe name) = Just name + mExeName _ = Nothing + +testComponents :: Set NamedComponent -> Set Text +testComponents = Set.fromList . mapMaybe mTestName . Set.toList + where + mTestName (CTest name) = Just name + mTestName _ = Nothing + +benchComponents :: Set NamedComponent -> Set Text +benchComponents = Set.fromList . mapMaybe mBenchName . Set.toList + where + mBenchName (CBench name) = Just name + mBenchName _ = Nothing + +isCLib :: NamedComponent -> Bool +isCLib CLib{} = True +isCLib _ = False + +isCExe :: NamedComponent -> Bool +isCExe CExe{} = True +isCExe _ = False + +isCTest :: NamedComponent -> Bool +isCTest CTest{} = True +isCTest _ = False + +isCBench :: NamedComponent -> Bool +isCBench CBench{} = True +isCBench _ = False + -- | A location to install a package into, either snapshot or local data InstallLocation = Snap | Local deriving (Show, Eq) diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index ad4892b82a..22059e3054 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -1,22 +1,19 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS -fno-warn-unused-do-bind #-} -- | Package identifier (name-version). module Stack.Types.PackageIdentifier - (PackageIdentifier(..) - ,toTuple - ,fromTuple - ,parsePackageIdentifier - ,parsePackageIdentifierFromString - ,packageIdentifierVersion - ,packageIdentifierName - ,packageIdentifierParser - ,packageIdentifierString - ,packageIdentifierText) + ( PackageIdentifier(..) + , toTuple + , fromTuple + , parsePackageIdentifier + , parsePackageIdentifierFromString + , packageIdentifierParser + , packageIdentifierString + , packageIdentifierText ) where import Control.Applicative @@ -47,10 +44,12 @@ instance Show PackageIdentifierParseFail where instance Exception PackageIdentifierParseFail -- | A pkg-ver combination. -data PackageIdentifier = - PackageIdentifier !PackageName - !Version - deriving (Eq,Ord,Generic,Data,Typeable) +data PackageIdentifier = PackageIdentifier + { -- | Get the name part of the identifier. + packageIdentifierName :: !PackageName + -- | Get the version part of the identifier. + , packageIdentifierVersion :: !Version + } deriving (Eq,Ord,Generic,Data,Typeable) instance NFData PackageIdentifier where rnf (PackageIdentifier !p !v) = @@ -79,14 +78,6 @@ toTuple (PackageIdentifier n v) = (n,v) fromTuple :: (PackageName,Version) -> PackageIdentifier fromTuple (n,v) = PackageIdentifier n v --- | Get the version part of the identifier. -packageIdentifierVersion :: PackageIdentifier -> Version -packageIdentifierVersion (PackageIdentifier _ ver) = ver - --- | Get the name part of the identifier. -packageIdentifierName :: PackageIdentifier -> PackageName -packageIdentifierName (PackageIdentifier name _) = name - -- | A parser for a package-version pair. packageIdentifierParser :: Parser PackageIdentifier packageIdentifierParser = diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs new file mode 100644 index 0000000000..0aff54b86e --- /dev/null +++ b/src/Stack/Types/PackageIndex.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Stack.Types.PackageIndex + ( PackageDownload (..) + , PackageCache (..) + , PackageCacheMap (..) + ) where + +import Control.Monad (mzero) +import Data.Aeson.Extended +import qualified Data.Binary as Binary +import Data.Binary.VersionTagged +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Stack.Types.PackageIdentifier + +data PackageCache = PackageCache + { pcOffset :: !Int64 + -- ^ offset in bytes into the 00-index.tar file for the .cabal file contents + , pcSize :: !Int64 + -- ^ size in bytes of the .cabal file + , pcDownload :: !(Maybe PackageDownload) + } + deriving (Generic) + +instance Binary PackageCache +instance NFData PackageCache +instance HasStructuralInfo PackageCache + +newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache) + deriving (Generic, Binary, NFData) +instance HasStructuralInfo PackageCacheMap +instance HasSemanticVersion PackageCacheMap + +data PackageDownload = PackageDownload + { pdSHA512 :: !ByteString + , pdUrl :: !ByteString + , pdSize :: !Word64 + } + deriving (Show, Generic) +instance Binary.Binary PackageDownload +instance HasStructuralInfo PackageDownload +instance NFData PackageDownload +instance FromJSON PackageDownload where + parseJSON = withObject "Package" $ \o -> do + hashes <- o .: "package-hashes" + sha512 <- maybe mzero return (Map.lookup ("SHA512" :: Text) hashes) + locs <- o .: "package-locations" + url <- + case reverse locs of + [] -> mzero + x:_ -> return x + size <- o .: "package-size" + return PackageDownload + { pdSHA512 = encodeUtf8 sha512 + , pdUrl = encodeUtf8 url + , pdSize = size + } diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs index 3051678ae6..c005aff1e0 100644 --- a/src/Stack/Types/StackT.hs +++ b/src/Stack/Types/StackT.hs @@ -6,7 +6,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -295,16 +294,18 @@ loggerFunc loc _src level msg = T.hPutStrLn outputChannel out)) where outputChannel = stderr getOutput maxLogLevel = - do date <- getDate + do timestamp <- getTimestamp l <- getLevel lc <- getLoc - return (T.pack date <> T.pack l <> T.decodeUtf8 (fromLogStr (toLogStr msg)) <> T.pack lc) - where getDate + return (T.pack timestamp <> T.pack l <> T.decodeUtf8 (fromLogStr (toLogStr msg)) <> T.pack lc) + where getTimestamp | maxLogLevel <= LevelDebug = - do now <- getCurrentTime - return (formatTime defaultTimeLocale "%Y-%m-%d %T%Q" now ++ - ": ") + do now <- getZonedTime + return (formatTime' now ++ ": ") | otherwise = return "" + where + formatTime' = + take timestampLength . formatTime defaultTimeLocale "%F %T.%q" getLevel | maxLogLevel <= LevelDebug = return ("[" ++ @@ -328,10 +329,16 @@ loggerFunc loc _src level msg = where line = show . fst . loc_start char = show . snd . loc_start +-- | The length of a timestamp in the format "YYYY-MM-DD hh:mm:ss.μμμμμμ". +-- This definition is top-level in order to avoid multiple reevaluation at runtime. +timestampLength :: Int +timestampLength = + length (formatTime defaultTimeLocale "%F %T.000000" (UTCTime (ModifiedJulianDay 0) 0)) + -- | With a sticky state, do the thing. withSticky :: (MonadIO m) => Bool -> (Sticky -> m b) -> m b -withSticky terminal m = do +withSticky terminal m = if terminal then do state <- liftIO (newMVar Nothing) originalMode <- liftIO (hGetBuffering stdout) diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 03eb9dd147..e215f107f2 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -42,7 +42,7 @@ upgrade gitRepo mresolver = withCanonicalizedSystemTempDirectory "stack-upgrade" Just repo -> do remote <- liftIO $ readProcess "git" ["ls-remote", repo, "master"] [] let latestCommit = head . words $ remote - if (latestCommit == $gitHash) then do + if latestCommit == $gitHash then do $logInfo "Already up-to-date, no upgrade required" return Nothing else do $logInfo "Cloning stack" diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs index 9053734b68..8643018666 100644 --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -31,7 +31,7 @@ module Stack.Upload import Control.Applicative import Control.Exception (bracket) import qualified Control.Exception as E -import Control.Monad (when) +import Control.Monad (when, unless) import Data.Aeson (FromJSON (..), ToJSON (..), eitherDecode', encode, @@ -217,7 +217,7 @@ mkUploader config us = do putStrLn "authentication failure" cfp <- credsFile config handleIO (const $ return ()) (removeFile cfp) - error $ "Authentication failure uploading to server" + error "Authentication failure uploading to server" 403 -> do putStrLn "forbidden upload" putStrLn "Usually means: you've already uploaded this package/version combination" @@ -240,7 +240,7 @@ printBody res = where loop = do bs <- brRead $ responseBody res - when (not $ S.null bs) $ do + unless (S.null bs) $ do S.hPut stdout bs loop diff --git a/src/System/Process/Log.hs b/src/System/Process/Log.hs index c4bf7731c1..53ebc74e50 100644 --- a/src/System/Process/Log.hs +++ b/src/System/Process/Log.hs @@ -27,7 +27,7 @@ logProcessRun = -- | Show a process arg including speechmarks when necessary. Just for -- debugging purposes, not functionally important. -showProcessArgDebug :: [Char] -> Text +showProcessArgDebug :: String -> Text showProcessArgDebug x | any special x = T.pack (show x) | otherwise = T.pack x diff --git a/src/System/Process/PagerEditor.hs b/src/System/Process/PagerEditor.hs index b302d3c26b..819aa6deef 100644 --- a/src/System/Process/PagerEditor.hs +++ b/src/System/Process/PagerEditor.hs @@ -97,11 +97,11 @@ editReaderWriter filename writer reader = -- | Run editor on a ByteString. editByteString :: String -> ByteString -> IO ByteString -editByteString f s = editReaderWriter f (flip hPut s) Data.ByteString.Lazy.readFile +editByteString f s = editReaderWriter f (`hPut` s) Data.ByteString.Lazy.readFile -- | Run editor on a String. editString :: String -> String -> IO String -editString f s = editReaderWriter f (flip hPutStr s) System.IO.readFile +editString f s = editReaderWriter f (`hPutStr` s) System.IO.readFile -- | Short-circuit first Just. orElse :: (Monad m) => m (Maybe a) -> m (Maybe a) -> m (Maybe a) diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs index fc9039b134..bed8b56ea6 100644 --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -71,25 +71,25 @@ import System.Exit import qualified System.FilePath as FP import System.Process.Log --- | Override the environment received by a child process +-- | Override the environment received by a child process. data EnvOverride = EnvOverride - { eoTextMap :: Map Text Text - , eoStringList :: [(String, String)] - , eoPath :: [FilePath] + { eoTextMap :: Map Text Text -- ^ Environment variables as map + , eoStringList :: [(String, String)] -- ^ Environment variables as association list + , eoPath :: [FilePath] -- ^ List of directories searched for executables (@PATH@) , eoExeCache :: IORef (Map FilePath (Either ReadProcessException (Path Abs File))) - , eoExeExtension :: String + , eoExeExtension :: String -- ^ @""@ or @".exe"@, depending on the platform , eoPlatform :: Platform } --- | Get the environment variables from @EnvOverride@ +-- | Get the environment variables from an 'EnvOverride'. unEnvOverride :: EnvOverride -> Map Text Text unEnvOverride = eoTextMap --- | Get the list of directories searched +-- | Get the list of directories searched (@PATH@). envSearchPath :: EnvOverride -> [FilePath] envSearchPath = eoPath --- | Modify an EnvOverride +-- | Modify the environment variables of an 'EnvOverride'. modifyEnvOverride :: MonadIO m => EnvOverride -> (Map Text Text -> Map Text Text) @@ -98,7 +98,7 @@ modifyEnvOverride eo f = mkEnvOverride (eoPlatform eo) (f $ eoTextMap eo) --- | Create a new @EnvOverride@ +-- | Create a new 'EnvOverride'. mkEnvOverride :: MonadIO m => Platform -> Map Text Text @@ -126,16 +126,16 @@ mkEnvOverride platform tm' = do Platform _ Windows -> True _ -> False --- | Helper conversion function +-- | Helper conversion function. envHelper :: EnvOverride -> Maybe [(String, String)] envHelper = Just . eoStringList -- | Read from the process, ignoring any output. readProcessNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => Maybe (Path Abs Dir) + => Maybe (Path Abs Dir) -- ^ Optional working directory -> EnvOverride - -> String - -> [String] + -> String -- ^ Command + -> [String] -- ^ Command line arguments -> m () readProcessNull wd menv name args = sinkProcessStdout wd menv name args CL.sinkNull @@ -143,11 +143,11 @@ readProcessNull wd menv name args = -- | Run the given command in the given directory. If it exits with anything -- but success, prints an error and then calls 'exitWith' to exit the program. readInNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => Path Abs Dir -- ^ directory to run in - -> FilePath -- ^ command to run + => Path Abs Dir -- ^ Directory to run in + -> FilePath -- ^ Command to run -> EnvOverride - -> [String] -- ^ command line arguments - -> Maybe Text + -> [String] -- ^ Command line arguments + -> Maybe Text -- ^ Optional additional error message -> m () readInNull wd cmd menv args errMsg = do result <- try (readProcessNull (Just wd) menv cmd args) @@ -169,27 +169,28 @@ readInNull wd cmd menv args errMsg = do -- | Try to produce a strict 'S.ByteString' from the stdout of a -- process. tryProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => Maybe (Path Abs Dir) + => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride - -> String - -> [String] + -> String -- ^ Command + -> [String] -- ^ Command line arguments -> m (Either ReadProcessException S.ByteString) tryProcessStdout wd menv name args = try (readProcessStdout wd menv name args) --- | Produce a strict 'S.ByteString' from the stdout of a --- process. Throws a 'ProcessExitedUnsuccessfully' exception if the --- process fails. +-- | Produce a strict 'S.ByteString' from the stdout of a process. +-- +-- Throws a 'ProcessExitedUnsuccessfully' exception if the process fails. readProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => Maybe (Path Abs Dir) + => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride - -> String - -> [String] + -> String -- ^ Command + -> [String] -- ^ Command line arguments -> m S.ByteString readProcessStdout wd menv name args = sinkProcessStdout wd menv name args CL.consume >>= liftIO . evaluate . S.concat +-- | An exception while trying to read from process. data ReadProcessException = ReadProcessException CreateProcess ExitCode L.ByteString L.ByteString | NoPathFound @@ -230,10 +231,10 @@ instance Exception ReadProcessException -- lots of output; for that use 'sinkProcessStdoutLogStderr'. sinkProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => Maybe (Path Abs Dir) + => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride - -> String - -> [String] + -> String -- ^ Command + -> [String] -- ^ Command line arguments -> Sink S.ByteString IO a -- ^ Sink for stdout -> m a sinkProcessStdout wd menv name args sinkStdout = do @@ -261,10 +262,10 @@ sinkProcessStdout wd menv name args sinkStdout = do -- | Consume the stdout and stderr of a process feeding strict 'S.ByteString's to the consumers. sinkProcessStderrStdout :: (MonadIO m, MonadLogger m) - => Maybe (Path Abs Dir) + => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride - -> String - -> [String] + -> String -- ^ Command + -> [String] -- ^ Command line arguments -> Sink S.ByteString IO e -- ^ Sink for stderr -> Sink S.ByteString IO o -- ^ Sink for stdout -> m (e,o) @@ -283,13 +284,17 @@ sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout = do -- | Perform pre-call-process tasks. Ensure the working directory exists and find the -- executable path. -preProcess :: (MonadIO m) => Maybe (Path Abs Dir) -> EnvOverride -> String -> m FilePath +preProcess :: (MonadIO m) + => Maybe (Path Abs Dir) -- ^ Optional directory to create if necessary + -> EnvOverride + -> String -- ^ Command name + -> m FilePath preProcess wd menv name = do name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name maybe (return ()) createTree wd return name' --- | Check if the given executable exists on the given PATH +-- | Check if the given executable exists on the given PATH. doesExecutableExist :: MonadIO m => EnvOverride -> String -> m Bool doesExecutableExist menv name = liftM isJust $ findExecutable menv name @@ -304,7 +309,9 @@ makeAbsolute = fmap FP.normalise . absolutize | FP.isRelative path = fmap (FP. path) getCurrentDirectory | otherwise = return path --- | Find the complete path for the executable +-- | Find the complete path for the executable. +-- +-- Throws a 'ReadProcessException' if unsuccessful. findExecutable :: (MonadIO m, MonadThrow n) => EnvOverride -> String -> m (n (Path Abs File)) findExecutable _ name | any FP.isPathSeparator name = do exists <- liftIO $ doesFileExist name @@ -340,7 +347,7 @@ findExecutable eo name = liftIO $ do return epath return $ either throwM return epath --- | Load up an EnvOverride from the standard environment +-- | Load up an 'EnvOverride' from the standard environment. getEnvOverride :: MonadIO m => Platform -> m EnvOverride getEnvOverride platform = liftIO $ @@ -348,7 +355,7 @@ getEnvOverride platform = mkEnvOverride platform . Map.fromList . map (T.pack *** T.pack) --- | Augment the PATH environment variable with the given extra paths +-- | Augment the PATH environment variable with the given extra paths. augmentPath :: [FilePath] -> Maybe Text -> Text augmentPath dirs mpath = T.intercalate (T.singleton FP.searchPathSeparator) diff --git a/src/System/Process/Run.hs b/src/System/Process/Run.hs index 9a13e7f849..63f8459068 100644 --- a/src/System/Process/Run.hs +++ b/src/System/Process/Run.hs @@ -6,7 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} --- | Reading from external processes. +-- | Run sub-processes. module System.Process.Run (runIn @@ -29,8 +29,9 @@ import System.Exit (exitWith, ExitCode (..)) import qualified System.Process import System.Process.Read --- | Run the given command in the given directory, inheriting stdout --- and stderr. If it exits with anything but success, prints an error +-- | Run the given command in the given directory, inheriting stdout and stderr. +-- +-- If it exits with anything but success, prints an error -- and then calls 'exitWith' to exit the program. runIn :: forall (m :: * -> *). (MonadLogger m,MonadIO m,MonadBaseControl IO m) @@ -38,7 +39,7 @@ runIn :: forall (m :: * -> *). -> FilePath -- ^ command to run -> EnvOverride -> [String] -- ^ command line arguments - -> Maybe Text + -> Maybe Text -- ^ optional additional error message -> m () runIn wd cmd menv args errMsg = do result <- try (callProcess (Just wd) menv cmd args) @@ -57,27 +58,31 @@ runIn wd cmd menv args errMsg = do liftIO (exitWith ec) Right () -> return () --- | Like as @System.Process.callProcess@, but takes an optional working directory and --- environment override, and throws ProcessExitedUnsuccessfully if the --- process exits unsuccessfully. Inherits stdout and stderr. +-- | Like 'System.Process.callProcess', but takes an optional working directory and +-- environment override, and throws 'ProcessExitedUnsuccessfully' if the +-- process exits unsuccessfully. +-- +-- Inherits stdout and stderr. callProcess :: (MonadIO m, MonadLogger m) - => Maybe (Path Abs Dir) + => Maybe (Path Abs Dir) -- ^ optional directory to run in -> EnvOverride - -> String - -> [String] + -> String -- ^ command to run + -> [String] -- ^ command line arguments -> m () callProcess = callProcess' id --- | Like as @System.Process.callProcess@, but takes an optional working directory and --- environment override, and throws ProcessExitedUnsuccessfully if the --- process exits unsuccessfully. Inherits stdout and stderr. +-- | Like 'System.Process.callProcess', but takes an optional working directory and +-- environment override, and throws 'ProcessExitedUnsuccessfully' if the +-- process exits unsuccessfully. +-- +-- Inherits stdout and stderr. callProcess' :: (MonadIO m, MonadLogger m) => (CreateProcess -> CreateProcess) - -> Maybe (Path Abs Dir) + -> Maybe (Path Abs Dir) -- ^ optional directory to run in -> EnvOverride - -> String - -> [String] + -> String -- ^ command to run + -> [String] -- ^ command line arguments -> m () callProcess' modCP wd menv cmd0 args = do cmd <- preProcess wd menv cmd0 diff --git a/src/main/Main.hs b/src/main/Main.hs index f1a0b60a7f..1158b6866f 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -25,6 +25,7 @@ import Data.List import qualified Data.Map as Map import qualified Data.Map.Strict as M import Data.Maybe +import Data.Maybe.Extra (mapMaybeA) import Data.Monoid import qualified Data.Set as Set import Data.Text (Text) @@ -38,9 +39,11 @@ import Distribution.System (buildArch) import Distribution.Text (display) import GHC.IO.Encoding (mkTextEncoding, textEncodingName) import Network.HTTP.Client +import Options.Applicative import Options.Applicative.Args import Options.Applicative.Builder.Extra -import Options.Applicative.Simple +import Options.Applicative.Complicated +import Options.Applicative.Simple (simpleVersion) import Options.Applicative.Types (readerAsk) import Path import Path.Extra (toFilePathNoTrailingSep) @@ -109,7 +112,7 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do isTerminal <- hIsTerminalDevice stdout execExtraHelp args dockerHelpOptName - (dockerOptsParser True) + (dockerOptsParser False) ("Only showing --" ++ Docker.dockerCmdName ++ "* options.") let commitCount = $gitCommitCount versionString' = concat $ concat @@ -121,100 +124,111 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do , [" ", display buildArch] ] - let numericVersion :: Parser (a -> a) - numericVersion = - infoOption - (showVersion Meta.version) - (long "numeric-version" <> - help "Show only version number") - + let globalOpts hide = + extraHelpOption hide progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*> + globalOptsParser hide + addCommand' cmd title footerStr constr = + addCommand cmd title footerStr constr (globalOpts True) + addSubCommands' cmd title footerStr = + addSubCommands cmd title footerStr (globalOpts True) eGlobalRun <- try $ - simpleOptions - versionString' + complicatedOptions + Meta.version + (Just versionString') "stack - The Haskell Tool Stack" "" - (numericVersion <*> extraHelpOption progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*> - globalOptsParser isTerminal) - (do addCommand "build" - "Build the project(s) in this directory/configuration" + (globalOpts False) + (do addCommand' "build" + "Build the package(s) in this directory/configuration" + cmdFooter buildCmd (buildOptsParser Build) - addCommand "install" + addCommand' "install" "Shortcut for 'build --copy-bins'" + cmdFooter buildCmd (buildOptsParser Install) - addCommand "uninstall" + addCommand' "uninstall" "DEPRECATED: This command performs no actions, and is present for documentation only" + cmdFooter uninstallCmd (many $ strArgument $ metavar "IGNORED") - addCommand "test" + addCommand' "test" "Shortcut for 'build --test'" + cmdFooter buildCmd (buildOptsParser Test) - addCommand "bench" + addCommand' "bench" "Shortcut for 'build --bench'" + cmdFooter buildCmd (buildOptsParser Bench) - addCommand "haddock" + addCommand' "haddock" "Shortcut for 'build --haddock'" + cmdFooter buildCmd (buildOptsParser Haddock) - addCommand "new" + addCommand' "new" "Create a new project from a template. Run `stack templates' to see available templates." + cmdFooter newCmd newOptsParser - addCommand "templates" + addCommand' "templates" "List the templates available for `stack new'." + cmdFooter templatesCmd (pure ()) - addCommand "init" + addCommand' "init" "Initialize a stack project based on one or more cabal packages" + cmdFooter initCmd initOptsParser - addCommand "solver" + addCommand' "solver" "Use a dependency solver to try and determine missing extra-deps" + cmdFooter solverCmd solverOptsParser - addCommand "setup" + addCommand' "setup" "Get the appropriate GHC for your project" + cmdFooter setupCmd setupParser - addCommand "path" + addCommand' "path" "Print out handy path information" + cmdFooter pathCmd - (fmap - catMaybes - (sequenceA - (map - (\(desc,name,_) -> - flag Nothing - (Just name) - (long (T.unpack name) <> - help desc)) - paths))) - addCommand "unpack" + (mapMaybeA + (\(desc,name,_) -> + flag Nothing + (Just name) + (long (T.unpack name) <> + help desc)) + paths) + addCommand' "unpack" "Unpack one or more packages locally" + cmdFooter unpackCmd (some $ strArgument $ metavar "PACKAGE") - addCommand "update" + addCommand' "update" "Update the package index" + cmdFooter updateCmd (pure ()) - addCommand "upgrade" + addCommand' "upgrade" "Upgrade to the latest stack (experimental)" + cmdFooter upgradeCmd - ((,) <$> (switch + ((,) <$> switch ( long "git" - <> help "Clone from Git instead of downloading from Hackage (more dangerous)" - )) - <*> (strOption + <> help "Clone from Git instead of downloading from Hackage (more dangerous)" ) + <*> strOption ( long "git-repo" <> help "Clone from specified git repository" <> value "https://github.com/commercialhaskell/stack" - <> showDefault - ))) - addCommand "upload" + <> showDefault )) + addCommand' "upload" "Upload a package to Hackage" + cmdFooter uploadCmd ((,,) <$> (many $ strArgument $ metavar "TARBALL/DIR") @@ -222,42 +236,61 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do <*> flag False True (long "sign" <> help "GPG sign & submit signature")) - addCommand "sdist" + addCommand' "sdist" "Create source distribution tarballs" + cmdFooter sdistCmd ((,) - <$> (many $ strArgument $ metavar "DIR") + <$> many (strArgument $ metavar "DIR") <*> optional pvpBoundsOption) - addCommand "dot" + addCommand' "dot" "Visualize your project's dependency graph using Graphviz dot" + cmdFooter dotCmd dotOptsParser - addCommand "exec" + addCommand' "exec" "Execute a command" + cmdFooter execCmd (execOptsParser Nothing) - addCommand "ghc" + addCommand' "ghc" "Run ghc" + cmdFooter execCmd (execOptsParser $ Just ExecGhc) - addCommand "ghci" - "Run ghci in the context of project(s) (experimental)" + addCommand' "ghci" + "Run ghci in the context of package(s) (experimental)" + cmdFooter + ghciCmd + ghciOptsParser + addCommand' "repl" + "Run ghci in the context of package(s) (experimental) (alias for 'ghci')" + cmdFooter ghciCmd ghciOptsParser - addCommand "runghc" + addCommand' "runghc" "Run runghc" + cmdFooter execCmd (execOptsParser $ Just ExecRunGhc) - addCommand "eval" + addCommand' "runhaskell" + "Run runghc (alias for 'runghc')" + cmdFooter + execCmd + (execOptsParser $ Just ExecRunGhc) + addCommand' "eval" "Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- -e CODE'" + cmdFooter evalCmd (evalOptsParser "CODE") - addCommand "clean" + addCommand' "clean" "Clean the local packages" + cmdFooter cleanCmd (pure ()) - addCommand "list-dependencies" + addCommand' "list-dependencies" "List the dependencies" + cmdFooter listDependenciesCmd (textOption (long "separator" <> metavar "SEP" <> @@ -265,16 +298,19 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do "and package version.") <> value " " <> showDefault)) - addCommand "query" + addCommand' "query" "Query general build information (experimental)" + cmdFooter queryCmd (many $ strArgument $ metavar "SELECTOR...") - addSubCommands + addSubCommands' "ide" "IDE-specific commands" - (do addCommand + cmdFooter + (do addCommand' "start" "Start the ide-backend service" + cmdFooter ideCmd ((,) <$> many (textArgument (metavar "TARGET" <> @@ -284,66 +320,81 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do metavar "OPTION" <> help "Additional options passed to GHCi" <> value [])) - addCommand + addCommand' "packages" "List all available local loadable packages" + cmdFooter packagesCmd (pure ()) - addCommand + addCommand' "load-targets" "List all load targets for a package target" + cmdFooter targetsCmd (textArgument (metavar "TARGET"))) - addSubCommands + addSubCommands' Docker.dockerCmdName "Subcommands specific to Docker use" - (do addCommand Docker.dockerPullCmdName + cmdFooter + (do addCommand' Docker.dockerPullCmdName "Pull latest version of Docker image from registry" + cmdFooter dockerPullCmd (pure ()) - addCommand "reset" + addCommand' "reset" "Reset the Docker sandbox" + cmdFooter dockerResetCmd (switch (long "keep-home" <> help "Do not delete sandbox's home directory")) - addCommand Docker.dockerCleanupCmdName + addCommand' Docker.dockerCleanupCmdName "Clean up Docker images and containers" + cmdFooter dockerCleanupCmd dockerCleanupOptsParser) - addSubCommands + addSubCommands' ConfigCmd.cfgCmdName "Subcommands specific to modifying stack.yaml files" - (addCommand ConfigCmd.cfgCmdSetName + cmdFooter + (addCommand' ConfigCmd.cfgCmdSetName "Sets a field in the project's stack.yaml to value" + cmdFooter cfgSetCmd configCmdSetParser) - addSubCommands + addSubCommands' Image.imgCmdName "Subcommands specific to imaging (EXPERIMENTAL)" - (addCommand Image.imgDockerCmdName + cmdFooter + (addCommand' Image.imgDockerCmdName "Build a Docker image for the project" + cmdFooter imgDockerCmd (boolFlags True "build" "building the project before creating the container" idm)) - addSubCommands + addSubCommands' "hpc" "Subcommands specific to Haskell Program Coverage" - (do addCommand "report" - "Generate HPC report a combined HPC report" - hpcReportCmd - hpcReportOptsParser) - addSubCommands + cmdFooter + (addCommand' "report" + "Generate HPC report a combined HPC report" + cmdFooter + hpcReportCmd + hpcReportOptsParser) + addSubCommands' Sig.sigCmdName "Subcommands specific to package signatures (EXPERIMENTAL)" - (do addSubCommands + cmdFooter + (do addSubCommands' Sig.sigSignCmdName "Sign a a single package or all your packages" - (do addCommand + cmdFooter + (do addCommand' Sig.sigSignSdistCmdName "Sign a single sdist package file" + cmdFooter sigSignSdistCmd Sig.sigSignSdistOpts))) case eGlobalRun of @@ -357,14 +408,15 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do , " [options] runghc [options]' comment is required." , "\nSee https://github.com/commercialhaskell/stack/blob/release/doc/GUIDE.md#ghcrunghc" ] throwIO exitCode - Right (global,run) -> do + Right (globalMonoid,run) -> do + let global = globalOptsFromMonoid isTerminal globalMonoid when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString' case globalReExecVersion global of Just expectVersion | expectVersion /= showVersion Meta.version -> throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version) _ -> return () - run global `catch` \e -> do + run global `catch` \e -> -- This special handler stops "stack: " from being printed before the -- exception case fromException e of @@ -374,6 +426,7 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do exitFailure where dockerHelpOptName = Docker.dockerCmdName ++ "-help" + cmdFooter = "Run 'stack --help' for global options that apply to all subcommands." -- | Print out useful path information in a human-readable format (and -- support others later). @@ -384,6 +437,11 @@ pathCmd keys go = (do env <- ask let cfg = envConfig env bc = envConfigBuildConfig cfg + -- This is the modified 'bin-path', + -- including the local GHC or MSYS if not configured to operate on + -- global GHC. + -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'. + -- So it's not the *minimal* override path. menv <- getMinimalEnvOverride snap <- packageDatabaseDeps local <- packageDatabaseLocal @@ -391,13 +449,18 @@ pathCmd keys go = snaproot <- installationRootDeps localroot <- installationRootLocal distDir <- distRelativeDir + hpcDir <- hpcReportDir forM_ + -- filter the chosen paths in flags (keys), + -- or show all of them if no specific paths chosen. (filter (\(_,key,_) -> null keys || elem key keys) paths) (\(_,key,path) -> liftIO $ T.putStrLn + -- If a single path type is requested, output it directly. + -- Otherwise, name all the paths. ((if length keys == 1 then "" else key <> ": ") <> @@ -410,18 +473,20 @@ pathCmd keys go = global snaproot localroot - distDir)))) + distDir + hpcDir)))) -- | Passed to all the path printers as a source of info. data PathInfo = PathInfo - {piBuildConfig :: BuildConfig - ,piEnvOverride :: EnvOverride - ,piSnapDb :: Path Abs Dir - ,piLocalDb :: Path Abs Dir - ,piGlobalDb :: Path Abs Dir - ,piSnapRoot :: Path Abs Dir - ,piLocalRoot :: Path Abs Dir - ,piDistDir :: Path Rel Dir + { piBuildConfig :: BuildConfig + , piEnvOverride :: EnvOverride + , piSnapDb :: Path Abs Dir + , piLocalDb :: Path Abs Dir + , piGlobalDb :: Path Abs Dir + , piSnapRoot :: Path Abs Dir + , piLocalRoot :: Path Abs Dir + , piDistDir :: Path Rel Dir + , piHpcDir :: Path Abs Dir } -- | The paths of interest to a user. The first tuple string is used @@ -437,85 +502,70 @@ paths :: [(String, Text, PathInfo -> Text)] paths = [ ( "Global stack root directory" , "global-stack-root" - , \pi -> - T.pack (toFilePathNoTrailingSep (configStackRoot (bcConfig (piBuildConfig pi))))) + , T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig ) , ( "Project root (derived from stack.yaml file)" , "project-root" - , \pi -> - T.pack (toFilePathNoTrailingSep (bcRoot (piBuildConfig pi)))) + , T.pack . toFilePathNoTrailingSep . bcRoot . piBuildConfig ) , ( "Configuration location (where the stack.yaml file is)" , "config-location" - , \pi -> - T.pack (toFilePath (bcStackYaml (piBuildConfig pi)))) + , T.pack . toFilePath . bcStackYaml . piBuildConfig ) , ( "PATH environment variable" , "bin-path" - , \pi -> - T.pack (intercalate [searchPathSeparator] (eoPath (piEnvOverride pi)))) + , T.pack . intercalate [searchPathSeparator] . eoPath . piEnvOverride ) , ( "Installed GHCs (unpacked and archives)" , "ghc-paths" - , \pi -> - T.pack (toFilePathNoTrailingSep (configLocalPrograms (bcConfig (piBuildConfig pi))))) + , T.pack . toFilePathNoTrailingSep . configLocalPrograms . bcConfig . piBuildConfig ) , ( "Local bin path where stack installs executables" , "local-bin-path" - , \pi -> - T.pack (toFilePathNoTrailingSep (configLocalBin (bcConfig (piBuildConfig pi))))) + , T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig ) , ( "Extra include directories" , "extra-include-dirs" - , \pi -> - T.intercalate - ", " - (Set.elems (configExtraIncludeDirs (bcConfig (piBuildConfig pi))))) + , T.intercalate ", " . Set.elems . configExtraIncludeDirs . bcConfig . piBuildConfig ) , ( "Extra library directories" , "extra-library-dirs" - , \pi -> - T.intercalate ", " (Set.elems (configExtraLibDirs (bcConfig (piBuildConfig pi))))) + , T.intercalate ", " . Set.elems . configExtraLibDirs . bcConfig . piBuildConfig ) , ( "Snapshot package database" , "snapshot-pkg-db" - , \pi -> - T.pack (toFilePathNoTrailingSep (piSnapDb pi))) + , T.pack . toFilePathNoTrailingSep . piSnapDb ) , ( "Local project package database" , "local-pkg-db" - , \pi -> - T.pack (toFilePathNoTrailingSep (piLocalDb pi))) + , T.pack . toFilePathNoTrailingSep . piLocalDb ) , ( "Global package database" , "global-pkg-db" - , \pi -> - T.pack (toFilePathNoTrailingSep (piGlobalDb pi))) + , T.pack . toFilePathNoTrailingSep . piGlobalDb ) , ( "GHC_PACKAGE_PATH environment variable" , "ghc-package-path" - , \pi -> mkGhcPackagePath True (piLocalDb pi) (piSnapDb pi) (piGlobalDb pi)) + , \pi -> mkGhcPackagePath True (piLocalDb pi) (piSnapDb pi) (piGlobalDb pi) ) , ( "Snapshot installation root" , "snapshot-install-root" - , \pi -> - T.pack (toFilePathNoTrailingSep (piSnapRoot pi))) + , T.pack . toFilePathNoTrailingSep . piSnapRoot ) , ( "Local project installation root" , "local-install-root" - , \pi -> - T.pack (toFilePathNoTrailingSep (piLocalRoot pi))) + , T.pack . toFilePathNoTrailingSep . piLocalRoot ) , ( "Snapshot documentation root" , "snapshot-doc-root" - , \pi -> - T.pack (toFilePathNoTrailingSep (piSnapRoot pi docDirSuffix))) + , \pi -> T.pack (toFilePathNoTrailingSep (piSnapRoot pi docDirSuffix))) , ( "Local project documentation root" , "local-doc-root" - , \pi -> - T.pack (toFilePathNoTrailingSep (piLocalRoot pi docDirSuffix))) + , \pi -> T.pack (toFilePathNoTrailingSep (piLocalRoot pi docDirSuffix))) , ( "Dist work directory" , "dist-dir" - , \pi -> - T.pack (toFilePathNoTrailingSep (piDistDir pi)))] + , T.pack . toFilePathNoTrailingSep . piDistDir ) + , ( "Where HPC reports and tix files are stored" + , "local-hpc-root" + , T.pack . toFilePathNoTrailingSep . piHpcDir ) ] data SetupCmdOpts = SetupCmdOpts { scoCompilerVersion :: !(Maybe CompilerVersion) - , scoForceReinstall :: !Bool - , scoUpgradeCabal :: !Bool - , scoStackSetupYaml :: !String - , scoGHCBindistURL :: !(Maybe String) + , scoForceReinstall :: !Bool + , scoUpgradeCabal :: !Bool + , scoStackSetupYaml :: !String + , scoGHCBindistURL :: !(Maybe String) } setupParser :: Parser SetupCmdOpts setupParser = SetupCmdOpts - <$> (optional $ argument readVersion + <$> optional (argument readVersion (metavar "GHC_VERSION" <> help ("Version of GHC to install, e.g. 7.10.2. " ++ "The default is to install the version implied by the resolver."))) @@ -531,13 +581,11 @@ setupParser = SetupCmdOpts ( long "stack-setup-yaml" <> help "Location of the main stack-setup.yaml file" <> value defaultStackSetupYaml - <> showDefault - ) - <*> (optional $ strOption + <> showDefault ) + <*> optional (strOption (long "ghc-bindist" <> metavar "URL" - <> help "Alternate GHC binary distribution (requires custom --ghc-variant)" - )) + <> help "Alternate GHC binary distribution (requires custom --ghc-variant)")) where readVersion = do s <- readerAsk @@ -571,8 +619,7 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do ensureCompiler SetupOpts { soptsInstallIfMissing = True , soptsUseSystem = - (configSystemGHC $ lcConfig lc) - && not scoForceReinstall + configSystemGHC (lcConfig lc) && not scoForceReinstall , soptsWantedCompiler = wantedCompiler , soptsCompilerCheck = compilerCheck , soptsStackYaml = mstack @@ -626,7 +673,7 @@ withUserFileLock go@GlobalOpts{} dir act = do -- Just in case of asynchronous exceptions, we need to be careful -- when using tryLockFile here: EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive) - (\fstTry -> maybe (return ()) (liftIO . unlockFile) fstTry) + (maybe (return ()) (liftIO . unlockFile)) (\fstTry -> case fstTry of Just lk -> EL.finally (act $ Just lk) (liftIO $ unlockFile lk) @@ -659,7 +706,7 @@ withConfigAndLock go@GlobalOpts{..} inner = do -- For now the non-locking version just unlocks immediately. -- That is, there's still a serialization point. withBuildConfig :: GlobalOpts - -> (StackT EnvConfig IO ()) + -> StackT EnvConfig IO () -> IO () withBuildConfig go inner = withBuildConfigAndLock go (\lk -> do munlockFile lk @@ -724,7 +771,7 @@ withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do munlockFile lk') cleanCmd :: () -> GlobalOpts -> IO () -cleanCmd () go = withBuildConfigAndLock go (\_ -> clean) +cleanCmd () go = withBuildConfigAndLock go (const clean) -- | Helper for build and install commands buildCmd :: BuildOpts -> GlobalOpts -> IO () @@ -774,7 +821,7 @@ uploadCmd (args, mpvpBounds, shouldSign) go = do return $ if r then (x:as, bs) else (as, x:bs) (files, nonFiles) <- partitionM doesFileExist args (dirs, invalid) <- partitionM doesDirectoryExist nonFiles - when (not (null invalid)) $ error $ + 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 @@ -782,8 +829,7 @@ uploadCmd (args, mpvpBounds, shouldSign) go = do config <- asks getConfig manager <- asks envManager let uploadSettings = - Upload.setGetManager (return manager) $ - Upload.defaultUploadSettings + Upload.setGetManager (return manager) Upload.defaultUploadSettings liftIO $ Upload.mkUploader config uploadSettings sigServiceUrl = "https://sig.commercialhaskell.org/" if null dirs @@ -812,22 +858,20 @@ sdistCmd (dirs, mpvpBounds) go = forM_ dirs' $ \dir -> do (tarName, tarBytes) <- getSDistTarball mpvpBounds dir distDir <- distDirFromDir dir - tarPath <- fmap (distDir ) $ parseRelFile tarName + tarPath <- (distDir ) <$> parseRelFile tarName liftIO $ createTree $ parent tarPath liftIO $ L.writeFile (toFilePath tarPath) tarBytes $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath) -- | Execute a command. execCmd :: ExecOpts -> GlobalOpts -> IO () -execCmd ExecOpts {..} go@GlobalOpts{..} = do - let needCmdErr = error "You must provide a command to exec, e.g. 'stack exec echo Hello World'" +execCmd ExecOpts {..} go@GlobalOpts{..} = case eoExtra of ExecOptsPlain -> do (cmd, args) <- case (eoCmd, eoArgs) of - (Just ExecGhc, args) -> return ("ghc", args) - (Just ExecRunGhc, args) -> return ("runghc", args) - (Nothing, cmd:args) -> return (cmd, args) - (Nothing, []) -> needCmdErr + (ExecCmd cmd, args) -> return (cmd, args) + (ExecGhc, args) -> return ("ghc", args) + (ExecRunGhc, args) -> return ("runghc", args) (manager,lc) <- liftIO $ loadConfigWithOpts go withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> runStackTGlobal manager (lcConfig lc) go $ @@ -836,23 +880,18 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = do (\_ _ -> return (cmd, args, [], [])) -- Unlock before transferring control away, whether using docker or not: (Just $ munlockFile lk) - (runStackTGlobal manager (lcConfig lc) go $ do + (runStackTGlobal manager (lcConfig lc) go $ exec plainEnvSettings cmd args) Nothing Nothing -- Unlocked already above. ExecOptsEmbellished {..} -> withBuildConfigAndLock go $ \lk -> do (cmd, args) <- case (eoCmd, eoArgs) of - (Nothing, cmd:args) -> return (cmd, args) - (Nothing, []) -> needCmdErr - (Just scmd, args) -> do - wc <- getWhichCompiler - let cmd = case scmd of - ExecGhc -> compilerExeName wc - -- NOTE: this won't currently work for GHCJS, because it doesn't have - -- a runghcjs binary. It probably will someday, though. - ExecRunGhc -> "run" ++ compilerExeName wc - return (cmd, args) + (ExecCmd cmd, args) -> return (cmd, args) + (ExecGhc, args) -> execCompiler "" args + -- NOTE: this won't currently work for GHCJS, because it doesn't have + -- a runghcjs binary. It probably will someday, though. + (ExecRunGhc, args) -> execCompiler "run" args let targets = concatMap words eoPackages unless (null targets) $ Stack.Build.build (const $ return ()) lk defaultBuildOpts @@ -860,13 +899,18 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = do } munlockFile lk -- Unlock before transferring control away. exec eoEnvSettings cmd args + where + execCompiler cmdPrefix args = do + wc <- getWhichCompiler + let cmd = cmdPrefix ++ compilerExeName wc + return (cmd, args) -- | Evaluate some haskell code inline. evalCmd :: EvalOpts -> GlobalOpts -> IO () evalCmd EvalOpts {..} go@GlobalOpts {..} = execCmd execOpts go where execOpts = - ExecOpts { eoCmd = Just ExecGhc + ExecOpts { eoCmd = ExecGhc , eoArgs = ["-e", evalArg] , eoExtra = evalExtra } @@ -905,7 +949,8 @@ packagesCmd () go@GlobalOpts{..} = targetsCmd :: Text -> GlobalOpts -> IO () targetsCmd target go@GlobalOpts{..} = withBuildConfig go $ - do (_realTargets,_,pkgs) <- ghciSetup Nothing [target] + do let bopts = defaultBuildOpts { boptsTargets = [target] } + (_realTargets,_,pkgs) <- ghciSetup bopts False Nothing pwd <- getWorkingDir targets <- fmap @@ -942,7 +987,7 @@ dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = do Docker.cleanup cleanupOpts cfgSetCmd :: ConfigCmd.ConfigCmdSet -> GlobalOpts -> IO () -cfgSetCmd co go@GlobalOpts{..} = do +cfgSetCmd co go@GlobalOpts{..} = withBuildConfigAndLock go (\_ -> do env <- ask @@ -951,7 +996,7 @@ cfgSetCmd co go@GlobalOpts{..} = do env) imgDockerCmd :: Bool -> GlobalOpts -> IO () -imgDockerCmd rebuild go@GlobalOpts{..} = do +imgDockerCmd rebuild go@GlobalOpts{..} = withBuildConfigExt go Nothing diff --git a/src/test/Stack/BuildPlanSpec.hs b/src/test/Stack/BuildPlanSpec.hs index a4e28ab69e..bbae0d1ffc 100644 --- a/src/test/Stack/BuildPlanSpec.hs +++ b/src/test/Stack/BuildPlanSpec.hs @@ -56,10 +56,8 @@ spec = beforeAll setup $ afterAll teardown $ do LoadConfig{..} <- loadConfig' manager bconfig <- loadBuildConfigRest manager (lcLoadBuildConfig Nothing Nothing) runStackT manager logLevel bconfig False False $ do - menv <- getMinimalEnvOverride mbp <- loadMiniBuildPlan $ LTS 2 9 eres <- try $ resolveBuildPlan - menv mbp (const False) (Map.fromList diff --git a/stack.cabal b/stack.cabal index 19e5b10fed..0a9a848dc8 100644 --- a/stack.cabal +++ b/stack.cabal @@ -8,8 +8,8 @@ description: Please see the README.md for usage information, and currently only intended for use by the executable. license: BSD3 license-file: LICENSE -author: Chris Done -maintainer: chrisdone@fpcomplete.com +author: Commercial Haskell SIG +maintainer: borsboom@fpcomplete.com category: Development build-type: Simple cabal-version: >=1.10 @@ -49,6 +49,7 @@ library ghc-options: -Wall exposed-modules: Options.Applicative.Builder.Extra Options.Applicative.Args + Options.Applicative.Complicated Stack.BuildPlan Stack.Config Stack.Config.Docker @@ -85,6 +86,7 @@ library Stack.Types.GhcPkgId Stack.Types.Image Stack.Types.PackageIdentifier + Stack.Types.PackageIndex Stack.Types.PackageName Stack.Types.TemplateName Stack.Types.Version @@ -111,6 +113,7 @@ library System.Process.Run Network.HTTP.Download.Verified Data.Attoparsec.Args + Data.Maybe.Extra Path.IO Path.Extra other-modules: Network.HTTP.Download @@ -122,7 +125,6 @@ library Data.Attoparsec.Combinators Data.Binary.VersionTagged Data.IORef.RunOnce - Data.Maybe.Extra Data.Set.Monad Distribution.Version.Extra build-depends: Cabal >= 1.18.1.5 @@ -146,6 +148,8 @@ library , cryptohash >= 0.11.6 , cryptohash-conduit , directory >= 1.2.1.0 + , edit-distance >= 0.2 + , either , enclosed-exceptions , exceptions >= 0.8.0.2 , extra @@ -167,7 +171,6 @@ library , mtl >= 2.1.3.1 , old-locale >= 1.0.0.6 , optparse-applicative - , optparse-simple >= 0.0.3 , path >= 0.5.1 , persistent >= 2.1.2 , persistent-sqlite >= 2.1.4