diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -44,9 +44,9 @@ If you'd like to help out but aren't sure what to work on, look for issues with the -[awaiting pr](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3A%22awaiting+pr%22) +[awaiting pull request](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3A%22awaiting+pull+request%22) label. Issues that are suitable for newcomers to the codebase have the -[newcomer](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3A%22awaiting+pr%22+label%3Anewcomer) +[newcomer friendly](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3A%22awaiting+pull+request%22+label%3a%22newcomer+friendly%22) label. Best to post a comment to the issue before you start work, in case anyone has already started. @@ -64,8 +64,8 @@ Note that stack contributors need not dogmatically follow the suggested hints but are encouraged to debate their usefulness. If you find a hint is not useful and detracts from readability, consider marking it in the [configuration -file](https://github.com/commercialhaskell/stack/blob/master/HLint.hs) to -be ignored. Please refer to the [HLint manual](https://github.com/ndmitchell/hlint#ignoring-hints) +file](https://github.com/commercialhaskell/stack/blob/master/.hlint.yaml) to +be ignored. Please refer to the [HLint manual](https://github.com/ndmitchell/hlint#readme) for configuration syntax. Quoting [@mgsloan](https://github.com/commercialhaskell/stack/pulls?utf8=%E2%9C%93&q=is%3Apr%20author%3Amgsloan): @@ -85,8 +85,7 @@ Once installed, you can check your changes with: ``` -hlint src/ test/ --cpp-simple --hint=HLint.hs +hlint src/ test/ --cpp-simple ``` -Where `--cpp-simple` strips `#` lines and `--hint` explicitly specifies the -configuration file. +Where `--cpp-simple` strips `#` lines. diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,215 @@ # Changelog +## v1.6.1 +Major changes: + +* Complete overhaul of how snapshots are defined, the `packages` and + `extra-deps` fields, and a number of related items. For full + details, please see + [the writeup on these changes](https://www.fpcomplete.com/blog/2017/07/stacks-new-extensible-snapshots). [PR #3249](https://github.com/commercialhaskell/stack/pull/3249), + see the PR description for a number of related issues. +* Upgraded to version 2.0 of the Cabal library. + +Behavior changes: + +* The `--install-ghc` flag is now on by default. For example, if you + run `stack build` in a directory requiring a GHC that you do not + currently have, Stack will automatically download and install that + GHC. You can explicitly set `install-ghc: false` or pass the flag + `--no-install-ghc` to regain the previous behavior. +* `stack ghci` no longer loads modules grouped by package. This is + always an improvement for plain ghci - it makes loading faster and + less noisy. For intero, this has the side-effect that it will no + longer load multiple packages that depend on TH loading relative + paths. TH relative paths will still work when loading a single + package into intero. See + [#3309](https://github.com/commercialhaskell/stack/issues/3309) +* Setting GHC options for a package via `ghc-options:` in your + `stack.yaml` will promote it to a local package, providing for more + consistency with flags and better reproducibility. See: + [#849](https://github.com/commercialhaskell/stack/issues/849) +* The `package-indices` setting with Hackage no longer works with the + `00-index.tar.gz` tarball, but must use the `01-index.tar.gz` file + to allow revised packages to be found. +* Options passsed via `--ghci-options` are now passed to the end of the + invocation of ghci, instead of the middle. This allows using `+RTS` + without an accompanying `-RTS`. +* When auto-detecting `--ghc-build`, `tinfo6` is now preferred over + `standard` if both versions of libtinfo are installed +* Addition of `stack build --copy-compiler-tool`, to allow tools like + intero to be installed globally for a particular compiler. + [#2643](https://github.com/commercialhaskell/stack/issues/2643) +* Stack will ask before saving hackage credentials to file. This new + prompt can be avoided by using the `save-hackage-creds` setting. Please + see [#2159](https://github.com/commercialhaskell/stack/issues/2159). +* The `GHCRTS` environment variable will no longer be passed through to + every program stack runs. Instead, it will only be passed through + commands like `exec`, `runghc`, `script`, `ghci`, etc. + See [#3444](https://github.com/commercialhaskell/stack/issues/3444). +* `ghc-options:` for specific packages will now come after the options + specified for all packages / particular sets of packages. See + [#3573](https://github.com/commercialhaskell/stack/issues/3573). +* The `pvp-bounds` feature is no longer fully functional, due to some + issues with the Cabal library's printer. See + [#3550](https://github.com/commercialhaskell/stack/issues/3550). + +Other enhancements: + +* The `with-hpack` configuration option specifies an Hpack executable to use + instead of the Hpack bundled with Stack. Please + see [#3179](https://github.com/commercialhaskell/stack/issues/3179). +* It's now possible to skip tests and benchmarks using `--skip` + flag +* `GitSHA1` is now `StaticSHA256` and is implemented using the `StaticSize 64 ByteString` for improved performance. + See [#3006](https://github.com/commercialhaskell/stack/issues/3006) +* Dependencies via HTTP(S) archives have been generalized to allow + local file path archives, as well as to support setting a + cryptographic hash (SHA256) of the contents for better + reproducibility. +* Allow specifying `--git-branch` when upgrading +* When running `stack upgrade` from a file which is different from the + default executable path (e.g., on POSIX systems, + `~/.local/bin/stack`), it will now additionally copy the new + executable over the currently running `stack` executable. If + permission is denied (such as in `/usr/local/bin/stack`), the user + will be prompted to try again using `sudo`. This is intended to + assist with the user experience when the `PATH` environment variable + has not been properly configured, see + [#3232](https://github.com/commercialhaskell/stack/issues/3232). +* `stack setup` for ghcjs will now install `alex` and `happy` if + they are not present. See + [#3109](https://github.com/commercialhaskell/stack/issues/3232). +* Added `stack ghci --only-main` flag, to skip loading / importing + all but main modules. See the ghci documentation page + for further info. +* Allow GHC's colored output to show through. GHC colors output + starting with version 8.2.1, for older GHC this does nothing. + Sometimes GHC's heuristics would work fine even before this change, + for example in `stack ghci`, but this override's GHC's heuristics + when they're broken by our collecting and processing GHC's output. +* Extended the `ghc-options` field to support `$locals`, `$targets`, + and `$everything`. See: + [#3329](https://github.com/commercialhaskell/stack/issues/3329) +* Better error message for case that `stack ghci` file targets are + combined with invalid package targets. See: + [#3342](https://github.com/commercialhaskell/stack/issues/3342) +* For profiling now uses `-fprof-auto -fprof-cafs` instead of + the deprecated `-auto-all -caf-all`. See: + [#3360](https://github.com/commercialhaskell/stack/issues/3360) +* Better descriptions are now available for `stack upgrade --help`. See: + [#3070](https://github.com/commercialhaskell/stack/issues/3070) +* When using Nix, nix-shell now depends always on gcc to prevent build errors + when using the FFI. As ghc depends on gcc anyway, this doesn't increase the + dependency footprint. +* `--cwd DIR` can now be passed to `stack exec` in order to execute the + program in a different directory. See: + [#3264](https://github.com/commercialhaskell/stack/issues/3264) +* Plan construction will detect if you add an executable-only package + as a library dependency, resulting in much clearer error + messages. See: + [#2195](https://github.com/commercialhaskell/stack/issues/2195). +* Addition of `--ghc-options` to `stack script` to pass options directly + to GHC. See: + [#3454](https://github.com/commercialhaskell/stack/issues/3454) +* Add hpack `package.yaml` to build Stack itself +* Add `ignore-revision-mismatch` setting. See: + [#3520](https://github.com/commercialhaskell/stack/issues/3520). +* Log when each individual test suite finishes. See: + [#3552](https://github.com/commercialhaskell/stack/issues/3552). +* Avoid spurious rebuilds when using `--file-watch` by not watching files for + executable, test and benchmark components that aren't a target. See: + [#3483](https://github.com/commercialhaskell/stack/issues/3483). +* Stack will now try to detect the width of the running terminal + (only on POSIX for the moment) and use that to better display + output messages. Work is ongoing, so some messages will not + be optimal yet. The terminal width can be overriden with the + new `--terminal-width` command-line option (this works even on + non-POSIX). +* Passing non local packages as targets to `stack ghci` will now + cause them to be used as `-package` args along with package + hiding. +* Detect when user changed .cabal file instead of package.yaml. This + was implemented upstream in hpack. See + [#3383](https://github.com/commercialhaskell/stack/issues/3383). +* Automatically run `autoreconf -i` as necessary when a `configure` + script is missing. See + [#3534](https://github.com/commercialhaskell/stack/issues/3534) +* GHC bindists can now be identified by their SHA256 checksum in addition to + their SHA1 checksum, allowing for more security in download. +* For filesystem setup-info paths, it's no longer assumed that the + directory is writable, instead a temp dir is used. See + [#3188](https://github.com/commercialhaskell/stack/issues/3188). + +Bug fixes: + +* `stack hoogle` correctly generates Hoogle databases. See: + [#3362](https://github.com/commercialhaskell/stack/issues/3362) +* `stack --docker-help` is now clearer about --docker implying + system-ghc: true, rather than both --docker and --no-docker. +* `stack haddock` now includes package names for all modules in the + Haddock index page. See: + [#2886](https://github.com/commercialhaskell/stack/issues/2886) +* Fixed an issue where Stack wouldn't detect missing Docker images + properly with newer Docker versions. + [#3171](https://github.com/commercialhaskell/stack/pull/3171) +* Previously, cabal files with just test-suite could cause build to fail + ([#2862](https://github.com/commercialhaskell/stack/issues/2862)) +* If an invalid snapshot file has been detected (usually due to + mismatched hashes), Stack will delete the downloaded file and + recommend either retrying or filing an issue upstream. See + [#3319](https://github.com/commercialhaskell/stack/issues/3319). +* Modified the flag parser within Stack to match the behavior of + Cabal's flag parser, which allows multiple sequential dashes. See + [#3345](https://github.com/commercialhaskell/stack/issues/3345) +* Now clears the hackage index cache if it is older than the + downloaded index. Fixes potential issue if stack was interrupted when + updating index. + See [#3033](https://github.com/commercialhaskell/stack/issues/3033) +* The Stack install script now respects the `-d` option. + See [#3366](https://github.com/commercialhaskell/stack/pull/3366). +* `stack script` can now handle relative paths to source files. + See [#3372](https://github.com/commercialhaskell/stack/issues/3372). +* Fixes explanation of why a target is needed by the build plan, when the + target is an extra dependency from the commandline. + See [#3378](https://github.com/commercialhaskell/stack/issues/3378). +* Previously, if you delete a yaml file from ~/.stack/build-plan, it would + trust the etag and not re-download. Fixed in this version. +* Invoking `stack --docker` in parallel now correctly locks the sqlite database. + See [#3400](https://github.com/commercialhaskell/stack/issues/3400). +* docs.haskellstack.org RTD documentation search is replaced by the mkdocs + search. Please see + [#3376](https://github.com/commercialhaskell/stack/issues/3376). +* `stack clean` now works with nix. See + [#3468](https://github.com/commercialhaskell/stack/issues/3376). +* `stack build --only-dependencies` no longer builds local project packages + that are depended on. See + [#3476](https://github.com/commercialhaskell/stack/issues/3476). +* Properly handle relative paths stored in the precompiled cache files. See + [#3431](https://github.com/commercialhaskell/stack/issues/3431). +* In some cases, Cabal does not realize that it needs to reconfigure, and must + be told to do so automatically. This would manifest as a "shadowed + dependency" error message. We now force a reconfigure whenever a dependency is + built, even if the package ID remained the same. See + [#2781](https://github.com/commercialhaskell/stack/issues/2781). +* When `--pvp-bounds` is enabled for sdist or upload, internal + dependencies could cause errors when uploaded to hackage. This is + fixed, see [#3290](https://github.com/commercialhaskell/stack/issues/3290) +* Fixes a bug where nonexistent hackage versions would cause stack to + suggest the same package name, without giving version info. See + [#3562](https://github.com/commercialhaskell/stack/issues/3562) +* Fixes a bug that has existed since 1.5.0, where + `stack setup --upgrade-cabal` would say that Cabal is already the latest + version, when it wasn't. +* Ensure that an `extra-dep` from a local directory is not treated as + a `$locals` for GHC options purposes. See + [#3574](https://github.com/commercialhaskell/stack/issues/3574). +* Building all executables only happens once instead of every + time. See + [#3229](https://github.com/commercialhaskell/stack/issues/3229) for + more info. + + ## 1.5.1 Bug fixes: @@ -193,7 +402,7 @@ ([#2986](https://github.com/commercialhaskell/stack/issues/2986)) * `stack exec` now takes `--rts-options` which passes the given arguments inside of `+RTS ... args .. -RTS` to the executable. This works around stack itself consuming - the RTS flags on Windows. ([#2986](https://github.com/commercialhaskell/stack/issues/2640)) + the RTS flags on Windows. ([#2640](https://github.com/commercialhaskell/stack/issues/2640)) * Upgraded `http-client-tls` version, which now offers support for the `socks5://` and `socks5h://` values in the `http_proxy` and `https_proxy` environment variables. @@ -1071,8 +1280,8 @@ * `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) + try to 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) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -3,8 +3,7 @@ import Data.List ( nub, sortBy ) import Data.Ord ( comparing ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.Package ( PackageId, InstalledPackageId, packageVersion, packageName ) import Distribution.PackageDescription ( PackageDescription(), Executable(..) ) import Distribution.InstalledPackageInfo (sourcePackageId, installedPackageId) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) @@ -13,7 +12,10 @@ import Distribution.Simple.PackageIndex (allPackages, dependencyClosure) import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) import Distribution.Simple.LocalBuildInfo ( installedPkgs, withLibLBI, withExeLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) +import Distribution.Types.PackageName (PackageName, unPackageName) +import Distribution.Types.UnqualComponentName (unUnqualComponentName) import Distribution.Verbosity ( Verbosity ) +import Distribution.Version ( showVersion ) import System.FilePath ( () ) main :: IO () @@ -29,27 +31,28 @@ createDirectoryIfMissingVerbose verbosity True dir withLibLBI pkg lbi $ \_ libcfg -> do withExeLBI pkg lbi $ \exe clbi -> - rewriteFile (dir "Build_" ++ exeName exe ++ ".hs") $ unlines - [ "module Build_" ++ exeName exe ++ " where" + rewriteFile (dir "Build_" ++ exeName' exe ++ ".hs") $ unlines + [ "module Build_" ++ exeName' exe ++ " where" , "" , "deps :: [String]" , "deps = " ++ (show $ formatdeps (transDeps libcfg clbi)) ] where + exeName' = unUnqualComponentName . exeName formatdeps = map formatone . sortBy (comparing unPackageName') formatone p = unPackageName' p ++ "-" ++ showVersion (packageVersion p) - unPackageName' p = case packageName p of PackageName n -> n + unPackageName' = unPackageName . packageName transDeps xs ys = either (map sourcePackageId . allPackages) handleDepClosureFailure $ dependencyClosure allInstPkgsIdx availInstPkgIds where allInstPkgsIdx = installedPkgs lbi allInstPkgIds = map installedPackageId $ allPackages allInstPkgsIdx - -- instPkgIds includes `stack-X.X.X`, which is not a depedency hence is missing from allInstPkgsIdx. Filter that out. - availInstPkgIds = filter (`elem` allInstPkgIds) . map fst $ testDeps xs ys + -- instPkgIds includes `stack-X.X.X`, which is not a dependency hence is missing from allInstPkgsIdx. Filter that out. + availInstPkgIds = filter (`elem` allInstPkgIds) $ testDeps xs ys handleDepClosureFailure unsatisfied = error $ "Computation of transitive dependencies failed." ++ if null unsatisfied then "" else " Unresolved dependencies: " ++ show unsatisfied -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [InstalledPackageId] +testDeps xs ys = map fst $ nub $ componentPackageDeps xs ++ componentPackageDeps ys diff --git a/doc/CONTRIBUTING.md b/doc/CONTRIBUTING.md --- a/doc/CONTRIBUTING.md +++ b/doc/CONTRIBUTING.md @@ -44,9 +44,9 @@ If you'd like to help out but aren't sure what to work on, look for issues with the -[awaiting pr](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3A%22awaiting+pr%22) +[awaiting pull request](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3A%22awaiting+pull+request%22) label. Issues that are suitable for newcomers to the codebase have the -[newcomer](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3A%22awaiting+pr%22+label%3Anewcomer) +[newcomer friendly](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3A%22awaiting+pull+request%22+label%3a%22newcomer+friendly%22) label. Best to post a comment to the issue before you start work, in case anyone has already started. @@ -64,8 +64,8 @@ Note that stack contributors need not dogmatically follow the suggested hints but are encouraged to debate their usefulness. If you find a hint is not useful and detracts from readability, consider marking it in the [configuration -file](https://github.com/commercialhaskell/stack/blob/master/HLint.hs) to -be ignored. Please refer to the [HLint manual](https://github.com/ndmitchell/hlint#ignoring-hints) +file](https://github.com/commercialhaskell/stack/blob/master/.hlint.yaml) to +be ignored. Please refer to the [HLint manual](https://github.com/ndmitchell/hlint#readme) for configuration syntax. Quoting [@mgsloan](https://github.com/commercialhaskell/stack/pulls?utf8=%E2%9C%93&q=is%3Apr%20author%3Amgsloan): @@ -85,8 +85,7 @@ Once installed, you can check your changes with: ``` -hlint src/ test/ --cpp-simple --hint=HLint.hs +hlint src/ test/ --cpp-simple ``` -Where `--cpp-simple` strips `#` lines and `--hint` explicitly specifies the -configuration file. +Where `--cpp-simple` strips `#` lines. diff --git a/doc/ChangeLog.md b/doc/ChangeLog.md --- a/doc/ChangeLog.md +++ b/doc/ChangeLog.md @@ -1,6 +1,215 @@ # Changelog +## v1.6.1 +Major changes: + +* Complete overhaul of how snapshots are defined, the `packages` and + `extra-deps` fields, and a number of related items. For full + details, please see + [the writeup on these changes](https://www.fpcomplete.com/blog/2017/07/stacks-new-extensible-snapshots). [PR #3249](https://github.com/commercialhaskell/stack/pull/3249), + see the PR description for a number of related issues. +* Upgraded to version 2.0 of the Cabal library. + +Behavior changes: + +* The `--install-ghc` flag is now on by default. For example, if you + run `stack build` in a directory requiring a GHC that you do not + currently have, Stack will automatically download and install that + GHC. You can explicitly set `install-ghc: false` or pass the flag + `--no-install-ghc` to regain the previous behavior. +* `stack ghci` no longer loads modules grouped by package. This is + always an improvement for plain ghci - it makes loading faster and + less noisy. For intero, this has the side-effect that it will no + longer load multiple packages that depend on TH loading relative + paths. TH relative paths will still work when loading a single + package into intero. See + [#3309](https://github.com/commercialhaskell/stack/issues/3309) +* Setting GHC options for a package via `ghc-options:` in your + `stack.yaml` will promote it to a local package, providing for more + consistency with flags and better reproducibility. See: + [#849](https://github.com/commercialhaskell/stack/issues/849) +* The `package-indices` setting with Hackage no longer works with the + `00-index.tar.gz` tarball, but must use the `01-index.tar.gz` file + to allow revised packages to be found. +* Options passsed via `--ghci-options` are now passed to the end of the + invocation of ghci, instead of the middle. This allows using `+RTS` + without an accompanying `-RTS`. +* When auto-detecting `--ghc-build`, `tinfo6` is now preferred over + `standard` if both versions of libtinfo are installed +* Addition of `stack build --copy-compiler-tool`, to allow tools like + intero to be installed globally for a particular compiler. + [#2643](https://github.com/commercialhaskell/stack/issues/2643) +* Stack will ask before saving hackage credentials to file. This new + prompt can be avoided by using the `save-hackage-creds` setting. Please + see [#2159](https://github.com/commercialhaskell/stack/issues/2159). +* The `GHCRTS` environment variable will no longer be passed through to + every program stack runs. Instead, it will only be passed through + commands like `exec`, `runghc`, `script`, `ghci`, etc. + See [#3444](https://github.com/commercialhaskell/stack/issues/3444). +* `ghc-options:` for specific packages will now come after the options + specified for all packages / particular sets of packages. See + [#3573](https://github.com/commercialhaskell/stack/issues/3573). +* The `pvp-bounds` feature is no longer fully functional, due to some + issues with the Cabal library's printer. See + [#3550](https://github.com/commercialhaskell/stack/issues/3550). + +Other enhancements: + +* The `with-hpack` configuration option specifies an Hpack executable to use + instead of the Hpack bundled with Stack. Please + see [#3179](https://github.com/commercialhaskell/stack/issues/3179). +* It's now possible to skip tests and benchmarks using `--skip` + flag +* `GitSHA1` is now `StaticSHA256` and is implemented using the `StaticSize 64 ByteString` for improved performance. + See [#3006](https://github.com/commercialhaskell/stack/issues/3006) +* Dependencies via HTTP(S) archives have been generalized to allow + local file path archives, as well as to support setting a + cryptographic hash (SHA256) of the contents for better + reproducibility. +* Allow specifying `--git-branch` when upgrading +* When running `stack upgrade` from a file which is different from the + default executable path (e.g., on POSIX systems, + `~/.local/bin/stack`), it will now additionally copy the new + executable over the currently running `stack` executable. If + permission is denied (such as in `/usr/local/bin/stack`), the user + will be prompted to try again using `sudo`. This is intended to + assist with the user experience when the `PATH` environment variable + has not been properly configured, see + [#3232](https://github.com/commercialhaskell/stack/issues/3232). +* `stack setup` for ghcjs will now install `alex` and `happy` if + they are not present. See + [#3109](https://github.com/commercialhaskell/stack/issues/3232). +* Added `stack ghci --only-main` flag, to skip loading / importing + all but main modules. See the ghci documentation page + for further info. +* Allow GHC's colored output to show through. GHC colors output + starting with version 8.2.1, for older GHC this does nothing. + Sometimes GHC's heuristics would work fine even before this change, + for example in `stack ghci`, but this override's GHC's heuristics + when they're broken by our collecting and processing GHC's output. +* Extended the `ghc-options` field to support `$locals`, `$targets`, + and `$everything`. See: + [#3329](https://github.com/commercialhaskell/stack/issues/3329) +* Better error message for case that `stack ghci` file targets are + combined with invalid package targets. See: + [#3342](https://github.com/commercialhaskell/stack/issues/3342) +* For profiling now uses `-fprof-auto -fprof-cafs` instead of + the deprecated `-auto-all -caf-all`. See: + [#3360](https://github.com/commercialhaskell/stack/issues/3360) +* Better descriptions are now available for `stack upgrade --help`. See: + [#3070](https://github.com/commercialhaskell/stack/issues/3070) +* When using Nix, nix-shell now depends always on gcc to prevent build errors + when using the FFI. As ghc depends on gcc anyway, this doesn't increase the + dependency footprint. +* `--cwd DIR` can now be passed to `stack exec` in order to execute the + program in a different directory. See: + [#3264](https://github.com/commercialhaskell/stack/issues/3264) +* Plan construction will detect if you add an executable-only package + as a library dependency, resulting in much clearer error + messages. See: + [#2195](https://github.com/commercialhaskell/stack/issues/2195). +* Addition of `--ghc-options` to `stack script` to pass options directly + to GHC. See: + [#3454](https://github.com/commercialhaskell/stack/issues/3454) +* Add hpack `package.yaml` to build Stack itself +* Add `ignore-revision-mismatch` setting. See: + [#3520](https://github.com/commercialhaskell/stack/issues/3520). +* Log when each individual test suite finishes. See: + [#3552](https://github.com/commercialhaskell/stack/issues/3552). +* Avoid spurious rebuilds when using `--file-watch` by not watching files for + executable, test and benchmark components that aren't a target. See: + [#3483](https://github.com/commercialhaskell/stack/issues/3483). +* Stack will now try to detect the width of the running terminal + (only on POSIX for the moment) and use that to better display + output messages. Work is ongoing, so some messages will not + be optimal yet. The terminal width can be overriden with the + new `--terminal-width` command-line option (this works even on + non-POSIX). +* Passing non local packages as targets to `stack ghci` will now + cause them to be used as `-package` args along with package + hiding. +* Detect when user changed .cabal file instead of package.yaml. This + was implemented upstream in hpack. See + [#3383](https://github.com/commercialhaskell/stack/issues/3383). +* Automatically run `autoreconf -i` as necessary when a `configure` + script is missing. See + [#3534](https://github.com/commercialhaskell/stack/issues/3534) +* GHC bindists can now be identified by their SHA256 checksum in addition to + their SHA1 checksum, allowing for more security in download. +* For filesystem setup-info paths, it's no longer assumed that the + directory is writable, instead a temp dir is used. See + [#3188](https://github.com/commercialhaskell/stack/issues/3188). + +Bug fixes: + +* `stack hoogle` correctly generates Hoogle databases. See: + [#3362](https://github.com/commercialhaskell/stack/issues/3362) +* `stack --docker-help` is now clearer about --docker implying + system-ghc: true, rather than both --docker and --no-docker. +* `stack haddock` now includes package names for all modules in the + Haddock index page. See: + [#2886](https://github.com/commercialhaskell/stack/issues/2886) +* Fixed an issue where Stack wouldn't detect missing Docker images + properly with newer Docker versions. + [#3171](https://github.com/commercialhaskell/stack/pull/3171) +* Previously, cabal files with just test-suite could cause build to fail + ([#2862](https://github.com/commercialhaskell/stack/issues/2862)) +* If an invalid snapshot file has been detected (usually due to + mismatched hashes), Stack will delete the downloaded file and + recommend either retrying or filing an issue upstream. See + [#3319](https://github.com/commercialhaskell/stack/issues/3319). +* Modified the flag parser within Stack to match the behavior of + Cabal's flag parser, which allows multiple sequential dashes. See + [#3345](https://github.com/commercialhaskell/stack/issues/3345) +* Now clears the hackage index cache if it is older than the + downloaded index. Fixes potential issue if stack was interrupted when + updating index. + See [#3033](https://github.com/commercialhaskell/stack/issues/3033) +* The Stack install script now respects the `-d` option. + See [#3366](https://github.com/commercialhaskell/stack/pull/3366). +* `stack script` can now handle relative paths to source files. + See [#3372](https://github.com/commercialhaskell/stack/issues/3372). +* Fixes explanation of why a target is needed by the build plan, when the + target is an extra dependency from the commandline. + See [#3378](https://github.com/commercialhaskell/stack/issues/3378). +* Previously, if you delete a yaml file from ~/.stack/build-plan, it would + trust the etag and not re-download. Fixed in this version. +* Invoking `stack --docker` in parallel now correctly locks the sqlite database. + See [#3400](https://github.com/commercialhaskell/stack/issues/3400). +* docs.haskellstack.org RTD documentation search is replaced by the mkdocs + search. Please see + [#3376](https://github.com/commercialhaskell/stack/issues/3376). +* `stack clean` now works with nix. See + [#3468](https://github.com/commercialhaskell/stack/issues/3376). +* `stack build --only-dependencies` no longer builds local project packages + that are depended on. See + [#3476](https://github.com/commercialhaskell/stack/issues/3476). +* Properly handle relative paths stored in the precompiled cache files. See + [#3431](https://github.com/commercialhaskell/stack/issues/3431). +* In some cases, Cabal does not realize that it needs to reconfigure, and must + be told to do so automatically. This would manifest as a "shadowed + dependency" error message. We now force a reconfigure whenever a dependency is + built, even if the package ID remained the same. See + [#2781](https://github.com/commercialhaskell/stack/issues/2781). +* When `--pvp-bounds` is enabled for sdist or upload, internal + dependencies could cause errors when uploaded to hackage. This is + fixed, see [#3290](https://github.com/commercialhaskell/stack/issues/3290) +* Fixes a bug where nonexistent hackage versions would cause stack to + suggest the same package name, without giving version info. See + [#3562](https://github.com/commercialhaskell/stack/issues/3562) +* Fixes a bug that has existed since 1.5.0, where + `stack setup --upgrade-cabal` would say that Cabal is already the latest + version, when it wasn't. +* Ensure that an `extra-dep` from a local directory is not treated as + a `$locals` for GHC options purposes. See + [#3574](https://github.com/commercialhaskell/stack/issues/3574). +* Building all executables only happens once instead of every + time. See + [#3229](https://github.com/commercialhaskell/stack/issues/3229) for + more info. + + ## 1.5.1 Bug fixes: @@ -193,7 +402,7 @@ ([#2986](https://github.com/commercialhaskell/stack/issues/2986)) * `stack exec` now takes `--rts-options` which passes the given arguments inside of `+RTS ... args .. -RTS` to the executable. This works around stack itself consuming - the RTS flags on Windows. ([#2986](https://github.com/commercialhaskell/stack/issues/2640)) + the RTS flags on Windows. ([#2640](https://github.com/commercialhaskell/stack/issues/2640)) * Upgraded `http-client-tls` version, which now offers support for the `socks5://` and `socks5h://` values in the `http_proxy` and `https_proxy` environment variables. @@ -1071,8 +1280,8 @@ * `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) + try to 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) diff --git a/doc/GUIDE.md b/doc/GUIDE.md --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -1,3 +1,5 @@ +
+ # User guide stack is a modern, cross-platform build tool for Haskell code. @@ -1083,7 +1085,7 @@ - aeson-0.10.0.0 - aeson-compat-0.3.0.0 - attoparsec-0.13.0.1 - - conduit-extra-1.1.9.2 + - conduit-extra-1.2.0 - email-validate-2.2.0 - hex-0.1.2 - http-api-data-0.2.2 @@ -1246,7 +1248,7 @@ path: ``` -michael@d30748af6d3d:~/helloworld$ stack path --local-bin-path +michael@d30748af6d3d:~/helloworld$ stack path --local-bin /home/michael/.local/bin ``` @@ -1577,8 +1579,9 @@ We've already used `stack exec` used multiple times in this guide. As you've likely already guessed, it allows you to run executables, but with a slightly modified environment. In particular: `stack exec` looks for executables on -stack's bin paths, and sets a few additional environment variables (like -`GHC_PACKAGE_PATH`, which tells GHC which package databases to use). +stack's bin paths, and sets a few additional environment variables (like adding +those paths to `PATH`, and setting `GHC_PACKAGE_PATH`, which tells GHC which +package databases to use). If you want to see exactly what the modified environment looks like, try: @@ -1787,7 +1790,7 @@ -} ``` -## Finding project configs, and the implicit global +## Finding project configs, and the implicit global project Whenever you run something with stack, it needs a `stack.yaml` project file. The algorithm stack uses to find this is: @@ -1818,6 +1821,15 @@ with it is put into isolated databases just like everywhere else. The only magic is that it's the catch-all project whenever you're running stack somewhere else. +## Setting stack root location + +`stack path --stack-root` will tell you the location of the "stack root". Among +other things, this is where stack stores downloaded programs and snapshot +packages. This location can be configured by setting the STACK_ROOT environment +variable or passing the `--stack-root` commandline option. It is particularly +useful to do this on Windows, where filepaths are limited (MAX_PATH), and things +can break when this limit is exceeded. + ## `stack.yaml` vs `.cabal` files Now that we've covered a lot of stack use cases, this quick summary of @@ -1897,22 +1909,7 @@ * [cabal-src](https://hackage.haskell.org/package/cabal-src) is mostly irrelevant in the presence of both stack and cabal sandboxes, both of which make it easier to add additional package sources easily. The mega-sdist executable that ships with cabal-src is, however, still relevant. Its functionality may some day be folded into stack * [stackage-cli](https://hackage.haskell.org/package/stackage-cli) was an initial attempt to make cabal-install work more easily with curated snapshots, but due to a slight impedance mismatch between cabal.config constraints and snapshots, it did not work as well as hoped. It is deprecated in favor of stack. -## More resources -There are lots of resources available for learning more about stack: - -* `stack --help` -* `stack --version` — identify the version and Git hash of the stack executable -* `--verbose` (or `-v`) — much more info about internal operations (useful for bug reports) -* The [home page](http://haskellstack.org) -* The [stack mailing list](https://groups.google.com/d/forum/haskell-stack) -* The [the FAQ](faq.md) -* The [stack wiki](https://github.com/commercialhaskell/stack/wiki) -* The [haskell-stack tag on Stack Overflow](http://stackoverflow.com/questions/tagged/haskell-stack) -* [Another getting started with stack tutorial](http://seanhess.github.io/2015/08/04/practical-haskell-getting-started.html) -* [Why is stack not cabal?](https://www.fpcomplete.com/blog/2015/06/why-is-stack-not-cabal) - - ## Fun features This is just a quick collection of fun and useful feature stack supports. @@ -1960,11 +1957,11 @@ An introduction into template-writing and a place for submitting official templates, you will find at [the stack-templates repository](https://github.com/commercialhaskell/stack-templates#readme). -### IDE +### Editor integration -stack has a work-in-progress suite of editor integrations, to do things like -getting type information in Emacs. For more information, see -[stack-ide](https://github.com/commercialhaskell/stack-ide#readme). +For editor integration, stack has a related project called +[intero](https://github.com/commercialhaskell/intero). It is particularly well +supported by emacs, but some other editors have integration for it as well. ### Visualizing dependencies @@ -1985,7 +1982,7 @@ eval "$(stack --bash-completion-script stack)" For more information and other shells, see [the Shell auto-completion wiki -page](https://github.com/commercialhaskell/stack/wiki/Shell-autocompletion) +page](https://docs.haskellstack.org/en/stable/shell_autocompletion) ### Docker @@ -2007,34 +2004,41 @@ ```yaml image: - # YOU NEED A `container` YAML SECTION FOR `stack image container` - container: - # YOU NEED A BASE IMAGE NAME. STACK LAYERS EXES ON TOP OF - # THE BASE IMAGE. PREPARE YOUR PROJECT IMAGE IN ADVANCE. PUT - # ALL YOUR RUNTIME DEPENDENCIES IN THE IMAGE. - base: "fpco/ubuntu-with-libgmp:14.04" - # YOU CAN OPTIONALY NAME THE IMAGE. STACK WILL USE THE PROJECT - # DIRECTORY NAME IF YOU LEAVE OUT THIS OPTION. - name: "fpco/hello-world" - # OPTIONALLY ADD A HASH OF LOCAL PROJECT DIRECTORIES AND THEIR - # DESTINATIONS INSIDE THE DOCKER IMAGE. - add: - man/: /usr/local/share/man/ - # OPTIONALLY SPECIFY A LIST OF EXECUTABLES. STACK WILL CREATE - # A TAGGED IMAGE FOR EACH IN THE LIST. THESE IMAGES WILL HAVE - # THEIR RESPECTIVE "ENTRYPOINT" SET. - entrypoints: - - stack + + # You need a `containers` yaml section for `stack image container`. + # A `container` section that does not contain a list is also valid. + containers: + + # This example just has one container. + - + # You need a base image name. Stack layers exes on top of + # the base image. Prepare your project image in advance by + # putting all your runtime dependencies in the image. + base: "fpco/ubuntu-with-libgmp:14.04" + + # You can optionally name the image. Stack will use the project + # directory name if you leave out this option. + name: "fpco/hello-world" + + # Optionally add a directory to a path inside the docker image. + add: + man/: /usr/local/share/man/ + + # Optionally specify a list of executables. Stack will create + # a tagged image for each in the list. these images will have + # their respective "ENTRYPOINT" set. + entrypoints: + - stack ``` and then run `stack image container` and then `docker images` to list the images. -Note that the executable will be built in the development environment -and copied to the container, so the dev OS must match that of the +Note that the executable will be built in the development environment +and copied to the container, so the dev OS must match that of the container OS. This is easily accomplished using [Docker integration](docker_integration.md), -under which the exe emitted by `stack build` will be built on the -Docker container, not the local OS. +under which the exe emitted by `stack build` will be built on the +Docker container, not the local OS. The executable will be stored under `/usr/local/bin/-exe` in the running container. @@ -2150,6 +2154,14 @@ executable-profiling: true ``` +### Further reading + +For more commands and uses, see [the official GHC chapter on +profiling](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/profiling.html), +[the Haskell wiki](https://wiki.haskell.org/How_to_profile_a_Haskell_program), +and [the chapter on profiling in Real World +Haskell](http://book.realworldhaskell.org/read/profiling-and-optimization.html). + ### Tracing To generate a backtrace in case of exceptions during a test or benchmarks run, @@ -2160,14 +2172,21 @@ `stack` now supports debugging and profiling with [DWARF information](https://ghc.haskell.org/trac/ghc/wiki/DWARF), -using the `--no-strip`, `--no-library-stripping`, and `--no-executable-shipping` +using the `--no-strip`, `--no-library-stripping`, and `--no-executable-stripping` flags to disable the default behavior of removing such information from compiled libraries and executables. -### Further reading +## More resources -For more commands and uses, see [the official GHC chapter on -profiling](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/profiling.html), -[the Haskell wiki](https://wiki.haskell.org/How_to_profile_a_Haskell_program), -and [the chapter on profiling in Real World -Haskell](http://book.realworldhaskell.org/read/profiling-and-optimization.html). +There are lots of resources available for learning more about stack: + +* `stack --help` +* `stack --version` — identify the version and Git hash of the stack executable +* `--verbose` (or `-v`) — much more info about internal operations (useful for bug reports) +* The [home page](http://haskellstack.org) +* The [stack mailing list](https://groups.google.com/d/forum/haskell-stack) +* The [the FAQ](faq.md) +* The [stack wiki](https://github.com/commercialhaskell/stack/wiki) +* The [haskell-stack tag on Stack Overflow](http://stackoverflow.com/questions/tagged/haskell-stack) +* [Another getting started with stack tutorial](http://seanhess.github.io/2015/08/04/practical-haskell-getting-started.html) +* [Why is stack not cabal?](https://www.fpcomplete.com/blog/2015/06/why-is-stack-not-cabal) diff --git a/doc/MAINTAINER_GUIDE.md b/doc/MAINTAINER_GUIDE.md --- a/doc/MAINTAINER_GUIDE.md +++ b/doc/MAINTAINER_GUIDE.md @@ -1,3 +1,5 @@ +
+ # Maintainer guide ## Next release: diff --git a/doc/README.md b/doc/README.md --- a/doc/README.md +++ b/doc/README.md @@ -1,3 +1,5 @@ +
+ # The Haskell Tool Stack Stack is a cross-platform program for developing Haskell @@ -53,7 +55,7 @@ - The `stack build` command will build the minimal project. - `stack exec my-project-exe` will execute the command. - If you just want to install an executable using stack, then all you have to do -is`stack install `. +is `stack install `. If you want to launch a REPL: @@ -116,7 +118,10 @@ 4. Once `stack` finishes building, check the stack version with `stack exec stack -- --version`. Make sure the version is the latest. 5. Look for issues tagged with - [`newcomer` and `awaiting-pr` labels](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3Anewcomer+label%3A%22awaiting+pr%22). + [newcomer friendly](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3a%22newcomer+friendly%22) + and + [awaiting pull request](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3A%22awaiting+pull+request%22) + labels. Build from source as a one-liner: @@ -173,4 +178,4 @@ project meeting the needs of Haskell users of all stripes. If you'd like to get involved with Stack, check out the -[newcomers label on the Github issue tracker](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3Anewcomer). +[newcomer friendly](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3a%22newcomer+friendly%22) label on the Github issue tracker. diff --git a/doc/SIGNING_KEY.md b/doc/SIGNING_KEY.md --- a/doc/SIGNING_KEY.md +++ b/doc/SIGNING_KEY.md @@ -1,3 +1,5 @@ +
+ # Signing key Releases are signed with this key: diff --git a/doc/architecture.md b/doc/architecture.md --- a/doc/architecture.md +++ b/doc/architecture.md @@ -1,3 +1,5 @@ +
+ # Architecture ## Terminology diff --git a/doc/build_command.md b/doc/build_command.md --- a/doc/build_command.md +++ b/doc/build_command.md @@ -1,3 +1,5 @@ +
+ # Build command ## Overview @@ -139,6 +141,14 @@ * `--keep-going`, to continue building packages even after some build step fails. The packages which depend upon the failed build won't get built. + +* `--skip`, to skip building components of a local package. It allows + you to skip test suites and benchmark without specifying other components + (e.g. `stack test --skip long-test-suite` will run the tests without the + `long-test-suite` test suite). Be aware that skipping executables won't work + the first time the package is built due to + [an issue in cabal](https://github.com/commercialhaskell/stack/issues/3229). + This option can be specified multiple times to skip multiple components. ## Flags diff --git a/doc/coverage.md b/doc/coverage.md --- a/doc/coverage.md +++ b/doc/coverage.md @@ -1,3 +1,5 @@ +
+ # Code Coverage Code coverage is enabled by passing the `--coverage` flag to `stack build`. diff --git a/doc/custom_snapshot.md b/doc/custom_snapshot.md --- a/doc/custom_snapshot.md +++ b/doc/custom_snapshot.md @@ -1,29 +1,61 @@ +
+ # Custom Snapshots -Custom snapshots allow you to create your own snapshots, which provide a list of -specific hackage packages to use, along with flags and ghc-options. The -definition of a basic snapshot looks like the following: +Custom snapshots were totally reworked with the extensible snapshots +overhaul in Stack 1.6.0, see +[the writeup](https://www.fpcomplete.com/blog/2017/07/stacks-new-extensible-snapshots) +and +[PR #3249](https://github.com/commercialhaskell/stack/pull/3249)). This +documentation covers the new syntax only. +Custom snapshots allow you to create your own snapshots, which provide +a list of packages to use, along with flags, ghc-options, and a few +other settings. Custom snapshots may extend any other snapshot that +can be specified in a `resolver` field. The packages specified follow +the syntax of `extra-deps` in the `stack.yaml` file, with one +exception: to ensure reproducibility of snapshots, local directories +are not allowed for custom snapshots (as they are expected to change +regularly). + ```yaml -resolver: ghc-8.0 +resolver: lts-8.21 # Inherits GHC version and package set +compiler: ghc-8.0.1 # Overwrites GHC version in the resolver, optional +name: my-snapshot # User-friendly name + +# Additional packages, follows extra-deps syntax packages: - - unordered-containers-0.2.7.1 - - hashable-1.2.4.0 - - text-1.2.2.1 +- unordered-containers-0.2.7.1 +- hashable-1.2.4.0 +- text-1.2.2.1 +# Override flags, can also override flags in the parent snapshot flags: unordered-containers: debug: true + +# Packages from the parent snapshot to ignore +drop-packages: +- wai-extra + +# Packages which should be hidden (affects script command's import +# parser +hidden: + wai: true + warp: false + +# Set GHC options for specific packages +ghc-options: + warp: + - -O2 ``` If you put this in a `snapshot.yaml` file in the same directory as your project, you can now use the custom snapshot like this: ```yaml -resolver: - name: simple-snapshot # Human readable name for the snapshot - location: simple-snapshot.yaml +resolver: snapshot.yaml ``` This is an example of a custom snapshot stored in the filesystem. They are @@ -38,24 +70,6 @@ `https://domain.org/snapshot-1.yaml`, it is expected to be immutable. If you change that file, then you lose any reproducibility guarantees. -## Extending snapshots - -The example custom snapshot above uses a compiler resolver, and so has few -packages. We can also extend existing snapshots, by using the usual -[resolver setting found in stack configurations](yaml_configuration.md#resolver). -All possible resolver choices are valid, so this means that custom snapshots can -even extend other custom snapshots. - -Lets say that we want to use `lts-7.1`, but use a different version of `text` -than the one it comes with, `1.2.2.1`. To downgrade it to `1.2.2.0`, we need a -custom snapshot file with the following: - -```yaml -resolver: lts-7.1 -packages: - - text-1.2.2.0 -``` - ### Overriding the compiler The following snapshot specification will be identical to `lts-7.1`, but instead @@ -117,57 +131,3 @@ text: developer: true ``` - -## YAML format - -In summary, the YAML format of custom snapshots has the following fields which -are directly related to the same fields in the -[build configuration format](yaml_configuration.md): - -* `resolver`, which specifies which snapshot to extend. It takes the same values - as the [`resolver` field in stack.yaml](yaml_configuration.md#resolver). - -* `compiler`, which specifies or overrides the selection of compiler. If - `resolver` is absent, then a specification of `compiler` is required. Its - semantics are the same as the - [`compiler` field in stack.yaml](yaml_configuration.md#compiler). - -Some fields look similar, but behave differently: - -* `flags` specifies which cabal flags to use with each package. In order to - specify a flag for a package, it *must* be listed in the `packages` list. - -* `ghc-options`, which specifies which cabal flags to use with each package. In - order to specify ghc-options for a package, it *must* be listed in the - `packages` list. The `*` member of the map specifies flags that apply to every - package in the `packages` list. - -There are two fields which work differently than in the build configuration -format: - -* `packages`, which specifies a list of hackage package versions. Note that - when a package version is overridden, no `flags` or `ghc-options` are taken - from the snapshot that is being extended. If you want the same options as the - snapshot being extended, they must be re-specified. - -* `drop-packages`, which specifies a list of packages to drop from the snapshot - being overridden. - -## Future enhancements - -We plan to enhance extensible snapshots in several ways in the future. See -[issue #1265, about "implicit snapshots"](https://github.com/commercialhaskell/stack/issues/1265). -In summary, in the future: - -1) It will be possible to use a specific git repository + commit hash in the -`packages` list, like in regular stack.yaml configuration. Currently, custom -snapshots only work with packages on hackage. - -2) `stack.yaml` configurations will implicitly create a snapshot. This means -that the non-local packages will get shared between your projects, so there is -less redundant compilation! - -3) `flags` and `ghc-options` for packages which are not listed in `packages` are -silently ignored. See -[#2654](https://github.com/commercialhaskell/stack/issues/2654) for the current -status of this. diff --git a/doc/dependency_visualization.md b/doc/dependency_visualization.md --- a/doc/dependency_visualization.md +++ b/doc/dependency_visualization.md @@ -1,3 +1,5 @@ +
+ # Dependency visualization You can use stack to visualize the dependencies between your packages and diff --git a/doc/docker_integration.md b/doc/docker_integration.md --- a/doc/docker_integration.md +++ b/doc/docker_integration.md @@ -1,3 +1,5 @@ +
+ Docker integration =============================================================================== diff --git a/doc/faq.md b/doc/faq.md --- a/doc/faq.md +++ b/doc/faq.md @@ -1,3 +1,5 @@ +
+ # FAQ So that this doesn't become repetitive: for the reasons behind the answers @@ -434,11 +436,7 @@ problem. Therefore, a possible workaround might be to turn off PIE related flags. -In Arch Linux, the support for this is provided by the `hardening-wrapper` -package. Some possible workarounds: - -* Selectively disabling its PIE forcing by setting `HARDENING_PIE=0` in `/etc/hardening-wrapper.conf`. -* Uninstalling the `hardening-wrapper` package and logging out then into your account again. +On Arch Linux, installing the `ncurses5-compat-libs` package from AUR resolves [this issue](https://github.com/commercialhaskell/stack/issues/2712). If you manage to work around this in other distributions, please include instructions here. @@ -521,4 +519,9 @@ Unfortunately `stack build` does not have an obvious equivalent to `cabal build -vN` which shows verbose output from GHC when building. The easiest workaround is to add `ghc-options: -vN` to the .cabal file or pass it via `stack build --ghc-options="-v"`. ## Does Stack support the Hpack specification? -Yes. You can run `stack init` as usual and Stack will create a matching `stack.yaml`. + +Yes: + +* If a package directory contains an Hpack `package.yaml` file, then Stack will use it to generate a `.cabal` file when building the package. +* You can run `stack init` to initialize a `stack.yaml` file regardless of whether your packages are declared with `.cabal` files or with Hpack `package.yaml` files. +* You can use the `with-hpack` configuration option to specify an Hpack executable to use instead of the Hpack bundled with Stack. diff --git a/doc/ghci.md b/doc/ghci.md --- a/doc/ghci.md +++ b/doc/ghci.md @@ -1,3 +1,5 @@ +
+ # GHCi `stack ghci` allows you to load components and files of your project into @@ -30,6 +32,25 @@ * `--no-load`, to skip loading all defined modules into ghci. You can then directly use `:load MyModule` to load a specific module in your project. + +## Loading just the main module + +By default, `stack ghci` loads and imports all of the modules in the package. +This allows you to easily use anything exported by your package. This is +usually quite convenient, but in some cases it makes sense to only load one +module, or no modules at all. The `--only-main` flag allows this. It specifies +that only the main module will be loaded, if any. This is particularly useful +in the following circumstances: + +1. You're loading the project in order to run it in ghci (e.g. via `main`), and + you intend to reload while developing. Without the `--only-main` flag, you + will need to quit and restart ghci whenever a module gets deleted. With the + flag, reloading should work fine in this case. + +2. If many of your modules have exports named the same thing, then you'll need to + refer to them using qualified names. To avoid this, it may be easier to use + `--only-main` to start with a blank slate and just import the modules you are + interested in. ## Loading a filepath directly diff --git a/doc/ghcjs.md b/doc/ghcjs.md --- a/doc/ghcjs.md +++ b/doc/ghcjs.md @@ -1,3 +1,5 @@ +
+ # GHCJS To use GHCJS with stack, place a GHCJS version in the [`compiler`](yaml_configuration.md#compiler) field of `stack.yaml`. After this, all stack commands should work with GHCJS! In particular: diff --git a/doc/install_and_upgrade.md b/doc/install_and_upgrade.md --- a/doc/install_and_upgrade.md +++ b/doc/install_and_upgrade.md @@ -1,3 +1,5 @@ +
+ # Install/upgrade For common Un*x operating systems (including macOS), all you need to do is run: diff --git a/doc/nix_integration.md b/doc/nix_integration.md --- a/doc/nix_integration.md +++ b/doc/nix_integration.md @@ -1,3 +1,5 @@ +
+ # Nix integration (since 0.1.10.0) diff --git a/doc/nonstandard_project_init.md b/doc/nonstandard_project_init.md --- a/doc/nonstandard_project_init.md +++ b/doc/nonstandard_project_init.md @@ -1,3 +1,5 @@ +
+ # Non-standard project initialization ## Introduction @@ -5,7 +7,9 @@ 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 +## Using a Cabal File + +New users may be confused by the fact that you must add dependencies to the package's cabal file, even in the case when you have already listed the package in the `stack.yaml`. In most cases, dependencies for your package that are in the Stackage snapshot need *only* be added to the diff --git a/doc/shell_autocompletion.md b/doc/shell_autocompletion.md --- a/doc/shell_autocompletion.md +++ b/doc/shell_autocompletion.md @@ -1,3 +1,5 @@ +
+ # Shell Auto-completion Note: if you installed a package for you Linux distribution, the bash diff --git a/doc/travis_ci.md b/doc/travis_ci.md --- a/doc/travis_ci.md +++ b/doc/travis_ci.md @@ -1,3 +1,5 @@ +
+ # Travis CI This page documents how to use Stack on @@ -5,11 +7,11 @@ familiarity with Travis. We provide two fully baked example files ready to be used on your projects: -* [The simple Travis configuration](https://raw.githubusercontent.com/commercialhaskell/stack/master/doc/travis-simple.yml) +* [The simple Travis configuration](https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/travis-simple.yml) is intended for applications that do not require multiple GHC support or cross-platform support. It builds and tests your project with just the settings present in your `stack.yaml` file. -* [The complex Travis configuration](https://raw.githubusercontent.com/commercialhaskell/stack/master/doc/travis-complex.yml) +* [The complex Travis configuration](https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/travis-complex.yml) is intended for projects that need to support multiple GHC versions and multiple OSes, such as open source libraries to be released to Hackage. It tests against cabal-install, as well as Stack on Linux @@ -28,7 +30,9 @@ You may also be interested in using AppVeyor, which supports Windows builds, for more cross-platform testing. There's a -[short blog post available on how to do this](http://www.snoyman.com/blog/2016/08/appveyor-haskell-windows-ci). +[short blog post available on how to do this](http://www.snoyman.com/blog/2016/08/appveyor-haskell-windows-ci), +or just copy in +[the appveyor.yml file](https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/appveyor.yml) The rest of this document explains the details of common Travis configurations for those of you who want to tweak the above @@ -69,15 +73,6 @@ - export PATH=$HOME/.local/bin:$PATH - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' ``` - -Once Travis whitelists the stack .deb files, we'll be able to simply include -stack in the `addons` section, and automatically use the newest version of -stack, avoiding that complicated `before_install` section This is being -tracked in the -[apt-source-whitelist](https://github.com/travis-ci/apt-source-whitelist/pull/7) -and -[apt-package-whitelist](https://github.com/travis-ci/apt-package-whitelist/issues/379) -issue trackers. ## Installing GHC diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -1,3 +1,5 @@ +
+ # YAML Configuration This page is intended to fully document all configuration options available in @@ -27,7 +29,7 @@ > Note: We define **project** to mean a directory that contains a `stack.yaml` > file, which specifies how to build a set of packages. We define **package** to -> be a package with a `.cabal` file. +> be a package with a `.cabal` file or Hpack `package.yaml` file. In your project-specific options, you specify both **which local packages** to build and **which dependencies to use** when building these packages. Unlike the @@ -41,162 +43,216 @@ version. Similarly, `extra-deps` will shadow the version specified in the resolver. -### packages +### resolver -The `packages` section lists all local (project) packages. The term _local -package_ should be differentiated from a _dependency package_. A local package -is something that you are developing as part of the project. Whereas a -dependency package is an external package that your project depends on. +Specifies which snapshot is to be used for this project. A snapshot +defines a GHC version, a number of packages available for +installation, and various settings like build flags. It is called a +resolver since a snapshot states how dependencies are resolved. There +are currently four resolver types: -In its simplest usage, it will be a list of directories or HTTP(S) URLs to a -tarball or a zip. For example: +* LTS Haskell snapshots, e.g. `resolver: lts-2.14` +* Stackage Nightly snapshot, e.g. `resolver: nightly-2015-06-16` +* No snapshot, just use packages shipped with the compiler + * For GHC this looks like `resolver: ghc-7.10.2` + * For GHCJS this looks like `resolver: ghcjs-0.1.0_ghc-7.10.2`. +* [Custom snapshot](custom_snapshot.md) +Each of these resolvers will also determine what constraints are placed on the +compiler version. See the [compiler-check](#compiler-check) option for some +additional control over compiler version. + +### packages and extra-deps + +_NOTE_ The contents of this section have changed significantly since +extensible snapshots were implemented (see: +[writeup](https://www.fpcomplete.com/blog/2017/07/stacks-new-extensible-snapshots) +and +[PR #3249](https://github.com/commercialhaskell/stack/pull/3249)). Most +old syntax is still supported with newer versions of Stack, but will +not be documented here. Instead, this section contains the recommended +syntax as of Stack v1.6.0. + +There are two types of packages that can be defined in your +`stack.yaml` file: + +* __Project packages__, those which you are actually working on in + your current project. These are local file paths in your project + directory. +* __Extra dependencies__, which are packages provided locally on top + of the snapshot definition of available packages. These can come + from Hackage (or an alternative package index you've defined, see + [package-indices](#package-indices)), an HTTP(S) or local archive, a + Git or Mercurial repository, or a local file path. + +These two sets of packages are both installed into your local package +database within your project. However, beyond that, they are +completely different: + +* Project packages will be built by default with a `stack build` + without specific targets. Extra dependencies will only be built if + they are depended upon. +* Test suites and benchmarks may be run for project packages. They are + never run for extra dependencies. + +The `packages` key is a simple list of file paths, which will be +treated as relative to the directory containing your `stack.yaml` +file. For example: + ```yaml packages: - - . - - dir1/dir2 - - https://example.com/foo/bar/baz-0.0.2.tar.gz +- . +- dir1/dir2 ``` -Each package directory or location specified must have a valid cabal file -present. Note that the subdirectories of the directory are not searched for -cabal files. Subdirectories will have to be specified as independent items in -the list of packages. +Each package directory or location specified must have a valid cabal +file or hpack `package.yaml` file present. Note that the +subdirectories of the directory are not searched for cabal +files. Subdirectories will have to be specified as independent items +in the list of packages. When the `packages` field is not present, it defaults to looking for a package in the project's root directory: ```yaml packages: - - . +- . ``` -#### Complex package locations (`location`) -More complex package locations can be specified in a key-value format with -`location` as a mandatory key. In addition to `location` some optional -key-value pairs can be specified to include specific subdirectories or to -specify package attributes as descibed later in this section. +The `extra-deps` key is given a list of all extra dependencies. If +omitted, it is taken as the empty list, e.g.: -In its simplest form a `location` key can have a single value in the same way -as described above for single value items. Alternativel it can have key-value -pairs as subfields to describe a git or mercurial repository location. For -example: +```yaml +extra-deps: [] +``` +It supports four different styles of values: + +#### Package index + +Packages can be stated by a name/version combination, which will be +looked up in the package index (by default, Hackage). The basic syntax +for this is: + ```yaml -packages: -- location: . -- location: dir1/dir2 -- location: https://example.com/foo/bar/baz-0.0.2.tar.gz -- location: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip -- location: - git: git@github.com:commercialhaskell/stack.git - commit: 6a86ee32e5b869a877151f74064572225e1a0398 -- location: - hg: https://example.com/hg/repo - commit: da39a3ee5e6b4b0d3255bfef95601890afd80709 +extra-deps: +- acme-missiles-0.3 ``` -Note: it is highly recommended that you only use SHA1 values for a Git or -Mercurial commit. Other values may work, but they are not officially supported, -and may result in unexpected behavior (namely, stack will not automatically -pull to update to new versions). +Using this syntax, the most recent Cabal file revision available will +be used. For more reproducibility of builds, it is recommended to +state the SHA256 hash of the cabal file contents as well, like this: -A `location` key can be accompanied by a `subdirs` key to look for cabal files -in a list of subdirectories as well in addition to the top level directory. +```yaml +extra-deps: +- acme-missiles-0.3@sha256:2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1 +``` -This could be useful for mega-repos like -[wai](https://github.com/yesodweb/wai/) or -[digestive-functors](https://github.com/jaspervdj/digestive-functors). +Or a specific revision number, with `0` being the original file: -The `subdirs` key can have multiple nested series items specifying a list of -subdirectories. For example: ```yaml -packages: -- location: . - subdirs: - - subdir1 - - subdir2 -- location: - git: git@github.com:yesodweb/wai - commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f - subdirs: - - auto-update - - wai -- location: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip - subdirs: - - auto-update - - wai +extra-deps: +- acme-missiles-0.3@rev:0 ``` +Note that specifying via SHA256 is slightly more resilient in that it +does not rely on correct ordering in the package index, while revision +number is likely simpler to use. In practice, both should guarantee +equally reproducible build plans. + If unspecified, `subdirs` defaults to `['.']` (i.e. look only in the top-level directory). Note that if you specify a value of `subdirs`, then `'.'` is _not_ included by default and needs to be explicitly specified if a required package is found in the top-level directory of the repository. -#### Local dependency packages (`extra-dep`) -A `location` key can be accompanied by an `extra-dep` key. When the -`extra-dep` key is set to `true` it indicates that the package should be -treated in the same way as a dependency package and not as part of the project. -This means the following: -* A _dependency package_ is built only if a user package or its dependencies - depend on it. Note that a regular _project package_ is built anyway even if - no other package depends on it. -* Its test suites and benchmarks will not be run. -* It will not be directly loaded in ghci when `stack ghci` is run. This is - important because if you specify huge dependencies as project packages then - ghci will have a nightmare loading everything. +#### Local file path -This is especially useful when you are tweaking upstream packages or want to -use latest versions of the upstream packages which are not yet on Hackage or -Stackage. +Like `packages`, local file paths can be used in `extra-deps`, and +will be relative to the directory containing the `stack.yaml` file. -For example: ```yaml -packages: -- location: . -- location: vendor/binary - extra-dep: true -- location: - git: git@github.com:yesodweb/wai - commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f - subdirs: - - auto-update - - wai - extra-dep: true +extra-deps: +- vendor/somelib ``` -### extra-deps +Note that if a local directory can be parsed as a package identifier, +Stack will treat it as a package identifier. In other words, if you +have a local directory named `foo-1.2.3`, instead of: -This is a list of package identifiers for additional packages from upstream to -be included. This is usually used to augment an LTS Haskell or Stackage Nightly -snapshot with a package that is not present or is at an different version than you -wish to use. +```yaml +extra-deps: +- foo-1.2.3 +``` +You should use the following to be explicit: + ```yaml extra-deps: -- acme-missiles-0.3 +- ./foo-1.2.3 ``` -Note that the `extra-dep` attribute in the `packages` section as described in -an earlier section is used for non-index local or remote packages while the -`extra-deps` section is for packages to be automatically pulled from an index -like Hackage. +#### Git and Mercurial repos -### resolver +You can give a Git or Mercurial repo at a specific commit, and Stack +will clone that repo. -Specifies how dependencies are resolved. There are currently four resolver types: +```yaml +extra-deps: +- git: git@github.com:commercialhaskell/stack.git + commit: 6a86ee32e5b869a877151f74064572225e1a0398 +- hg: https://example.com/hg/repo + commit: da39a3ee5e6b4b0d3255bfef95601890afd80709 +``` -* LTS Haskell snapshots, e.g. `resolver: lts-2.14` -* Stackage Nightly snapshot, e.g. `resolver: nightly-2015-06-16` -* No snapshot, just use packages shipped with the compiler - * For GHC this looks like `resolver: ghc-7.10.2` - * For GHCJS this looks like `resolver: ghcjs-0.1.0_ghc-7.10.2`. -* [Custom snapshot](custom_snapshot.md) +__NOTE__ It is highly recommended that you only use SHA1 values for a +Git or Mercurial commit. Other values may work, but they are not +officially supported, and may result in unexpected behavior (namely, +Stack will not automatically pull to update to new versions). +Another problem with this is that your build will not be deterministic, +because when someone else tries to build the project they can get a +different checkout of the package. -Each of these resolvers will also determine what constraints are placed on the -compiler version. See the [compiler-check](#compiler-check) option for some -additional control over compiler version. +A common practice in the Haskell world is to use "megarepos", or +repositories with multiple packages in various subdirectories. Some +common examples include [wai](https://github.com/yesodweb/wai/) and +[digestive-functors](https://github.com/jaspervdj/digestive-functors). To +support this, you may also specify `subdirs` for repositories, e.g.: +```yaml +extra-deps: +- git: git@github.com:yesodweb/wai + commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f + subdirs: + - auto-update + - wai +``` + +If unspecified, `subdirs` defaults to `subdirs: [.]`, or looking for a +package in the root of the repo. + +#### Archives (HTTP(S) or local filepath) + +This one's pretty straightforward: you can use HTTP and HTTPS URLs and +local filepaths referring to either tarballs or ZIP files. + +__NOTE__ Stack assumes that these files never change after downloading +to avoid needing to make an HTTP request on each build. + +```yaml +extra-deps: +- https://example.com/foo/bar/baz-0.0.2.tar.gz +- archive: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + subdirs: + - wai + - warp +- archive: ../acme-missiles-0.3.tar.gz + sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b +``` + +Note that HTTP(S) URLs also support `subdirs` like repos to allow for +archives of megarepos. In order to leverage this, use `location: +http://...`. + ### flags Flags can be set for each package separately, e.g. @@ -207,8 +263,8 @@ flag-name: true ``` -Flags will only affect packages in your `packages` and `extra-deps` settings. -Packages that come from the snapshot global database are not affected. +If a specified flag is different than the one specified for a snapshot package, +then the snapshot package will automatically be promoted to be an extra-dep. ### image @@ -246,7 +302,7 @@ - app-backend ``` -will build one container tagged `myproject:latest` which contains the project +will build one container tagged `myproject:latest` which contains the project including the `/etc/app-backend` configuration data. Another container tagged `myproject-app-backend:latest` based on the `myproject:latest` @@ -265,7 +321,7 @@ Warning: Specified resolver could not satisfy all dependencies. Some external packages have been added as dependencies. - You can suppress this message by removing it from stack.yaml + You can omit this message by removing it from stack.yaml ' ``` @@ -321,7 +377,7 @@ download-prefix: https://s3.amazonaws.com/hackage.fpcomplete.com/package/ # HTTP location of the package index - http: https://s3.amazonaws.com/hackage.fpcomplete.com/00-index.tar.gz + http: https://s3.amazonaws.com/hackage.fpcomplete.com/01-index.tar.gz # Or, if using Hackage Security below, give the root URL: http: https://s3.amazonaws.com/hackage.fpcomplete.com/ @@ -348,6 +404,13 @@ Will now be ignored. +__IMPORTANT__ Hackage and its mirrors typically have two index files +available: `00-index.tar.gz` and `01-index.tar.gz`. The former is a +legacy file for backwards compatibility. It does not contain the cabal +file revisions produced by Hackage, and therefore _will not work_ with +most snapshots. Instead, you need to use `01-index.tar.gz` to ensure +that exact revisions can be found, ensuring more reproducible builds. + ### system-ghc Enables or disables using the GHC available on the PATH. @@ -362,8 +425,9 @@ ### install-ghc -Whether or not to automatically install GHC when necessary. Default is `false`, -which means stack will prompt you to run `stack setup` as needed. +Whether or not to automatically install GHC when necessary. Since +Stack 1.5.0, the default is `true`, which means Stack will not ask you +before downloading and installing GHC. ### skip-ghc-check @@ -398,6 +462,13 @@ - /opt/foo/lib ``` +Since these are system-dependent absolute paths, it is recommended that you +specify these in your `config.yaml` within the stack root (usually, `~/.stack`). +If you control the build environment in your project's ``stack.yaml``, perhaps +through docker or other means, then it may well make sense to include these +there as well. + + ### with-gcc Specify a path to gcc explicitly, rather than relying on the normal path resolution. @@ -406,6 +477,14 @@ with-gcc: /usr/local/bin/gcc-5 ``` +### with-hpack + +Use an Hpack executable, rather than using the bundled Hpack. + +```yaml +with-hpack: /usr/local/bin/hpack +``` + ### compiler-check (Since 0.1.4) @@ -447,15 +526,30 @@ ```yaml ghc-options: # All packages - "*": -Wall + "$locals": -Wall + "$targets": -Werror + "$everything": -O2 some-package: -DSOME_CPP_FLAG ``` -Caveat emptor: setting options like this will affect your snapshot packages, -which can lead to unpredictable behavior versus official Stackage snapshots. -This is in contrast to the `ghc-options` command line flag, which will only -affect the packages specified by the [`apply-ghc-options` option](yaml_configuration.md#apply-ghc-options). +Since 1.6.0, setting a GHC options for a specific package will +automatically promote it to a local package (much like setting a +custom package flag). However, setting options via `$everything` on all flags +will not do so (see +[Github discussion](https://github.com/commercialhaskell/stack/issues/849#issuecomment-320892095) +for reasoning). This can lead to unpredicable behavior by affecting +your snapshot packages. +The behavior of the `$locals`, `$targets`, and `$everything` special +keys mirrors the behavior for the +[`apply-ghc-options` setting](#apply-ghc-options), which affects +command line parameters. + +NOTE: Prior to version 1.6.0, the `$locals`, `$targets`, and +`$everything` keys were not support. Instead, you could use `"*"` for +the behavior represented now by `$everything`. It is highly +recommended to switch to the new, more expressive, keys. + ### apply-ghc-options (Since 0.1.6) @@ -535,6 +629,13 @@ (Since 0.1.5) +__NOTE__ As of Stack 1.6.0, this feature does not reliably work, due +to issues with the Cabal library's printer. Stack will generate a +warning when a lossy conversion occurs, in which case you may need to +disable this setting. See +[#3550](https://github.com/commercialhaskell/stack/issues/3550) for +more information. + When using the `sdist` and `upload` commands, this setting determines whether the cabal file's dependencies should be modified to reflect PVP lower and upper bounds. Values are `none` (unchanged), `upper` (add upper bounds), `lower` (add @@ -713,7 +814,7 @@ set per project by passing `-p "category:value"` to the `stack new` command. * _copyright_ - sets the `copyright` property in cabal. It is typically the name of the holder of the copyright on the package and the year(s) from which - copyright is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs` + copyright is claimed. For example: `Copyright (c) 2006-2007 Joe Bloggs` * _github-username_ - used to generate `homepage` and `source-repository` in cabal. For instance `github-username: myusername` and `stack new my-project new-template` would result: @@ -733,7 +834,7 @@ author-name: Your Name author-email: youremail@example.com category: Your Projects Category - copyright: 'Copyright: (c) 2017 Your Name' + copyright: 'Copyright (c) 2017 Your Name' github-username: yourusername ``` @@ -756,9 +857,27 @@ ``` Since 1.5.0 - -# urls +### ignore-revision-mismatch + +Cabal files in packages can be specified via exact revisions to deal +with Hackage revision metadata. The default behavior of Stack (since +1.6.0) is to fail if an exact match is not found. In some cases +(specifically, when using a legacy `00-index.tar.gz` file), users may +wish to allow a mismatch. In such cases, you can change +`ignore-revision-mismatch` from `false` to `true`. + +```yaml +ignore-revision-mismatch: false +``` + +For more information, see +[the Github issue #3520 discussion](https://github.com/commercialhaskell/stack/issues/3520). + +Since 1.6.0 + +### urls + Customize the URLs where `stack` looks for snapshot build plans. The default configuration is @@ -772,3 +891,91 @@ **Note:** The `latest-snapshot-url` field has been deprecated in favor of `latest-snapshot` and will be removed in a future version of `stack`. + +### jobs + +Specifies how many build tasks should be run in parallel. This can be overloaded +on the commandline via `-jN`, for example `-j2`. The default is to use the +number of processors reported by your CPU. One usage for this might be to avoid +running out of memory by setting it to 1, like this: + +```yaml +jobs: 1 +``` + +### work-dir + +Specifies relative path of work directory (default is `.stack-work`. This can +also be specified by env var or cli flag, in particular, the earlier items in +this list take precedence: + +1. `--work-dir DIR` passed on the commandline +2. `work-dir` in stack.yaml +3. `STACK_WORK` environment variable + +Since 0.1.10.0 + +### skip-msys + +Skips checking for and installing msys2 when stack is setting up the +environment. This is only useful on Windows machines, and usually doesn't make +sense in project configurations, just in `config.yaml`. Defaults to `false`, so +if this is used, it only really makes sense to use it like this: + +```yaml +skip-msys: true +``` + +Since 0.1.2.0 + +### concurrent-tests + +This option specifies whether test-suites should be executed concurrently with +each-other. The default for this is true, since this is usually fine and it +often means that tests can complete earlier. However, if some test-suites +require exclusive access to some resource, or require a great deal of CPU or +memory resources, then it makes sense to set this to `false` (the default is +`true`). + +```yaml +concurrent-tests: false +``` + +Since 0.1.2.0 + +### extra-path + +This option specifies additional directories to prepend to the PATH environment +variable. These will be used when resolving the location of executables, and +will also be visible in the `PATH` variable of processes run by stack. + +For example, to prepend `/path-to-some-dep/bin` to your PATh: + +```yaml +extra-path: +- /path-to-some-dep/bin +``` + +One thing to note is that other paths added by stack - things like the project's +bin dir and the compiler's bin dir - will take precedence over those specified +here (the automatic paths get prepended). + +Since 0.1.4.0 + +### local-programs-path + +This overrides the location of the programs directory, where tools like ghc and +msys get installed. + +On most systems, this defaults to a folder called `programs` +within the stack root directory. On windows, if the `LOCALAPPDATA` environment +variable exists, then it defaults to `$LOCALAPPDATA/Programs/stack/`, which +follows windows conventions. + +Since 1.3.0 + +### default-template + +This option specifies which template to use with `stack new`, when none is +specified. The default is called `new-template`. The other templates are listed +in [the stack-templates repo](https://github.com/commercialhaskell/stack-templates/). diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,340 @@ +name: stack +version: '1.6.1' +synopsis: The Haskell Tool Stack +description: ! 'Please see the README.md for usage information, and + the wiki on Github for more details. Also, note that + the API for the library is not currently stable, and may + change significantly, even between minor releases. It is + currently only intended for use by the executable.' +category: Development +author: Commercial Haskell SIG +maintainer: manny@fpcomplete.com +license: BSD3 +github: commercialhaskell/stack.git +homepage: http://haskellstack.org +custom-setup: + dependencies: + - base + - Cabal + - filepath +extra-source-files: +- CONTRIBUTING.md +- ChangeLog.md +- README.md +- doc/*.md +- package.yaml +- src/setup-shim/StackSetupShim.hs +- stack.yaml +- test/package-dump/ghc-7.10.txt +- test/package-dump/ghc-7.8.4-osx.txt +- test/package-dump/ghc-7.8.txt +ghc-options: +- -Wall +- -fwarn-tabs +- -fwarn-incomplete-uni-patterns +- -fwarn-incomplete-record-updates +dependencies: +- Cabal +- aeson +- annotated-wl-pprint +- ansi-terminal +- async +- attoparsec +- base >=4.9 && < 5 +- base64-bytestring +- blaze-builder +- bytestring +- clock +- conduit +- conduit-extra +- containers +- cryptonite +- cryptonite-conduit +- deepseq +- directory +- echo +- exceptions +- extra +- fast-logger +- file-embed +- filelock +- filepath +- fsnotify +- generic-deriving +- hackage-security +- hashable +- hastache +- hpack +- hpc +- http-client +- http-client-tls +- http-conduit +- http-types +- memory +- microlens +- microlens-mtl +- mintty +- monad-logger +- mono-traversable +- mtl +- neat-interpolation +- network-uri +- open-browser +- optparse-applicative +- path +- path-io +- persistent +- persistent-sqlite +- persistent-template +- pretty +- primitive +- process +- project-template +- regex-applicative-text +- resourcet +- retry +- semigroups +- split +- stm +- store +- store-core +- streaming-commons +- tar +- template-haskell +- temporary +- text +- text-metrics +- th-reify-many +- time +- tls +- transformers +- unicode-transforms +- unix-compat +- unliftio +- unordered-containers +- vector +- yaml +- zip-archive +- zlib +when: +- condition: os(windows) + then: + cpp-options: -DWINDOWS + dependencies: + - Win32 + else: + build-tools: + - hsc2hs + dependencies: + - bindings-uname + - pid1 + - unix +library: + source-dirs: src/ + ghc-options: + - -fwarn-identities + exposed-modules: + - Control.Concurrent.Execute + - Data.Aeson.Extended + - Data.Attoparsec.Args + - Data.Attoparsec.Combinators + - Data.Attoparsec.Interpreter + - Data.IORef.RunOnce + - Data.Store.VersionTagged + - Network.HTTP.Download + - Network.HTTP.Download.Verified + - Options.Applicative.Args + - Options.Applicative.Builder.Extra + - Options.Applicative.Complicated + - Path.CheckInstall + - Path.Extra + - Path.Find + - Paths_stack + - Stack.Build + - Stack.Build.Cache + - Stack.Build.ConstructPlan + - Stack.Build.Execute + - Stack.Build.Haddock + - Stack.Build.Installed + - Stack.Build.Source + - Stack.Build.Target + - Stack.BuildPlan + - Stack.Clean + - Stack.Config + - Stack.Config.Build + - Stack.Config.Urls + - Stack.Config.Docker + - Stack.Config.Nix + - Stack.ConfigCmd + - Stack.Constants + - Stack.Constants.Config + - Stack.Coverage + - Stack.Docker + - Stack.Docker.GlobalDB + - Stack.Dot + - Stack.Exec + - Stack.Fetch + - Stack.FileWatch + - Stack.GhcPkg + - Stack.Ghci + - Stack.Ghci.Script + - Stack.Hoogle + - Stack.IDE + - Stack.Image + - Stack.Init + - Stack.New + - Stack.Nix + - Stack.Options.BenchParser + - Stack.Options.BuildMonoidParser + - Stack.Options.BuildParser + - Stack.Options.CleanParser + - Stack.Options.ConfigParser + - Stack.Options.Completion + - Stack.Options.DockerParser + - Stack.Options.DotParser + - Stack.Options.ExecParser + - Stack.Options.GhcBuildParser + - Stack.Options.GhciParser + - Stack.Options.GhcVariantParser + - Stack.Options.GlobalParser + - Stack.Options.HaddockParser + - Stack.Options.HpcReportParser + - Stack.Options.LogLevelParser + - Stack.Options.NewParser + - Stack.Options.NixParser + - Stack.Options.PackageParser + - Stack.Options.ResolverParser + - Stack.Options.ScriptParser + - Stack.Options.SDistParser + - Stack.Options.SolverParser + - Stack.Options.TestParser + - Stack.Options.Utils + - Stack.Package + - Stack.PackageDump + - Stack.PackageIndex + - Stack.PackageLocation + - Stack.Path + - Stack.Prelude + - Stack.PrettyPrint + - Stack.Runners + - Stack.Script + - Stack.SDist + - Stack.Setup + - Stack.Setup.Installed + - Stack.SetupCmd + - Stack.Sig + - Stack.Sig.GPG + - Stack.Sig.Sign + - Stack.Snapshot + - Stack.Solver + - Stack.StaticBytes + - Stack.Types.Build + - Stack.Types.BuildPlan + - Stack.Types.CompilerBuild + - Stack.Types.Urls + - Stack.Types.Compiler + - Stack.Types.Config + - Stack.Types.Config.Build + - Stack.Types.Docker + - Stack.Types.FlagName + - Stack.Types.GhcPkgId + - Stack.Types.Image + - Stack.Types.Nix + - Stack.Types.Package + - Stack.Types.PackageDump + - Stack.Types.PackageIdentifier + - Stack.Types.PackageIndex + - Stack.Types.PackageName + - Stack.Types.Resolver + - Stack.Types.Runner + - Stack.Types.Sig + - Stack.Types.TemplateName + - Stack.Types.Version + - Stack.Types.VersionIntervals + - Stack.Upgrade + - Stack.Upload + - Text.PrettyPrint.Leijen.Extended + - System.Process.Log + - System.Process.PagerEditor + - System.Process.Read + - System.Process.Run + - System.Terminal + other-modules: + - Hackage.Security.Client.Repository.HttpLib.HttpClient + when: + - condition: 'os(windows)' + then: + source-dirs: src/windows/ + else: + source-dirs: src/unix/ +executables: + stack: + main: Main.hs + source-dirs: src/main + ghc-options: + - -threaded + dependencies: + - stack + other-modules: + - Paths_stack + when: + - condition: flag(static) + ld-options: + - -static + - -pthread + - condition: ! '!(flag(disable-git-info))' + cpp-options: -DUSE_GIT_INFO + dependencies: + - gitrev + - optparse-simple + - condition: flag(hide-dependency-versions) + cpp-options: -DHIDE_DEP_VERSIONS + - condition: flag(supported-build) + cpp-options: -DSUPPORTED_BUILD +tests: + stack-test: + main: Test.hs + source-dirs: src/test + ghc-options: + - -threaded + dependencies: + - QuickCheck + - hspec + - stack + - smallcheck + stack-integration-test: + main: IntegrationSpec.hs + source-dirs: + - test/integration + - test/integration/lib + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - hspec + when: + - condition: ! '!(flag(integration-tests))' + buildable: false +flags: + static: + description: Pass -static/-pthread to ghc when linking the stack binary. + manual: true + default: false + disable-git-info: + description: Disable compile-time inclusion of current git info in stack + manual: true + default: false + hide-dependency-versions: + description: Hides dependency versions from "stack --version", used only by building + with stack.yaml + manual: true + default: false + integration-tests: + description: Run the integration test suite + manual: true + default: false + supported-build: + description: If false, causes "stack --version" to issue a warning about the build being unsupported. True only if building with stack.yaml + manual: true + default: false diff --git a/src/Control/Concurrent/Execute.hs b/src/Control/Concurrent/Execute.hs --- a/src/Control/Concurrent/Execute.hs +++ b/src/Control/Concurrent/Execute.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} -- Concurrent execution with dependencies. Types currently hard-coded for needs @@ -10,16 +11,9 @@ , runActions ) where -import Control.Applicative -import Control.Concurrent.Async (Concurrently (..), async) import Control.Concurrent.STM -import Control.Exception -import Control.Monad (join, unless) -import Data.Foldable (sequenceA_) -import Data.Set (Set) +import Stack.Prelude import qualified Data.Set as Set -import Data.Typeable (Typeable) -import Prelude -- Fix AMP warning import Stack.Types.PackageIdentifier data ActionType @@ -79,7 +73,7 @@ _ <- async $ withProgress $ esCompleted es if threads <= 1 then runActions' es - else runConcurrently $ sequenceA_ $ replicate threads $ Concurrently $ runActions' es + else replicateConcurrently_ threads $ runActions' es readTVarIO $ esExceptions es runActions' :: ExecuteState -> IO () diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -1,7 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -- | Extensions to Aeson parsing of objects. @@ -27,23 +26,16 @@ , (..!=) ) where -import Control.Monad.Logger (MonadLogger, logWarn) -import Control.Monad.Trans (lift) import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell) import Data.Aeson as Export hiding ((.:), (.:?)) import qualified Data.Aeson as A import Data.Aeson.Types hiding ((.:), (.:?)) import qualified Data.HashMap.Strict as HashMap -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (unpack, Text) +import Data.Text (unpack) import qualified Data.Text as T -import Data.Traversable -import qualified Data.Traversable as Traversable -import GHC.Generics (Generic) import Generics.Deriving.Monoid (mappenddefault, memptydefault) -import Prelude -- Fix redundant import warnings +import Stack.Prelude -- | Extends @.:@ warning to include field name. (.:) :: FromJSON a => Object -> Text -> Parser a @@ -111,7 +103,7 @@ :: MonadLogger m => FilePath -> [JSONWarning] -> m () logJSONWarnings fp = - mapM_ (\w -> $logWarn ("Warning: " <> T.pack fp <> ": " <> T.pack (show w))) + mapM_ (\w -> logWarn ("Warning: " <> T.pack fp <> ": " <> T.pack (show w))) -- | Handle warnings in a sub-object. jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a @@ -128,7 +120,7 @@ :: Traversable t => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a) jsonSubWarningsT f = - Traversable.mapM (jsonSubWarnings . return) =<< f + mapM (jsonSubWarnings . return) =<< f -- | Handle warnings in a @Maybe Traversable@ of sub-objects. jsonSubWarningsTT @@ -136,7 +128,7 @@ => WarningParser (u (t (WithJSONWarnings a))) -> WarningParser (u (t a)) jsonSubWarningsTT f = - Traversable.mapM (jsonSubWarningsT . return) =<< f + mapM (jsonSubWarningsT . return) =<< f -- Parsed JSON value without any warnings noJSONWarnings :: a -> WithJSONWarnings a @@ -153,6 +145,8 @@ instance Monoid WarningParserMonoid where mempty = memptydefault mappend = mappenddefault +instance IsString WarningParserMonoid where + fromString s = mempty { wpmWarnings = [fromString s] } -- Parsed JSON value with its warnings data WithJSONWarnings a = WithJSONWarnings a [JSONWarning] @@ -165,8 +159,12 @@ -- | Warning output from 'WarningParser'. data JSONWarning = JSONUnrecognizedFields String [Text] + | JSONGeneralWarning !Text instance Show JSONWarning where show (JSONUnrecognizedFields obj [field]) = "Unrecognized field in " <> obj <> ": " <> T.unpack field show (JSONUnrecognizedFields obj fields) = "Unrecognized fields in " <> obj <> ": " <> T.unpack (T.intercalate ", " fields) + show (JSONGeneralWarning t) = T.unpack t +instance IsString JSONWarning where + fromString = JSONGeneralWarning . T.pack diff --git a/src/Data/Attoparsec/Args.hs b/src/Data/Attoparsec/Args.hs --- a/src/Data/Attoparsec/Args.hs +++ b/src/Data/Attoparsec/Args.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | Parsing of stack command line arguments @@ -5,12 +6,13 @@ ( EscapingMode(..) , argsParser , parseArgs + , parseArgsFromString ) where -import Control.Applicative import Data.Attoparsec.Text (()) import qualified Data.Attoparsec.Text as P -import Data.Text (Text) +import qualified Data.Text as T +import Stack.Prelude -- | Mode for parsing escape characters. data EscapingMode @@ -21,6 +23,10 @@ -- | Parse arguments using 'argsParser'. parseArgs :: EscapingMode -> Text -> Either String [String] parseArgs mode = P.parseOnly (argsParser mode) + +-- | Parse using 'argsParser' from a string. +parseArgsFromString :: EscapingMode -> String -> Either String [String] +parseArgsFromString mode = P.parseOnly (argsParser mode) . T.pack -- | A basic argument parser. It supports space-separated text, and -- string quotation with identity escaping: \x -> x. diff --git a/src/Data/Attoparsec/Combinators.hs b/src/Data/Attoparsec/Combinators.hs --- a/src/Data/Attoparsec/Combinators.hs +++ b/src/Data/Attoparsec/Combinators.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} -- | More readable combinators for writing parsers. module Data.Attoparsec.Combinators where -import Control.Applicative -import Data.Monoid +import Stack.Prelude -- | Concatenate two parsers. appending :: (Applicative f,Monoid a) diff --git a/src/Data/Attoparsec/Interpreter.hs b/src/Data/Attoparsec/Interpreter.hs --- a/src/Data/Attoparsec/Interpreter.hs +++ b/src/Data/Attoparsec/Interpreter.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {- | This module implements parsing of additional arguments embedded in a comment when stack is invoked as a script interpreter @@ -52,7 +54,6 @@ , getInterpreterArgs ) where -import Control.Applicative import Data.Attoparsec.Args import Data.Attoparsec.Text (()) import qualified Data.Attoparsec.Text as P @@ -64,8 +65,9 @@ import Data.List (intercalate) import Data.Text (pack) import Stack.Constants +import Stack.Prelude import System.FilePath (takeExtension) -import System.IO (IOMode (ReadMode), withBinaryFile, stderr, hPutStrLn) +import System.IO (stderr, hPutStrLn) -- | Parser to extract the stack command line embedded inside a comment -- after validating the placement and formatting rules for a valid @@ -138,14 +140,18 @@ parseArgStr str = case P.parseOnly (argsParser Escaping) (pack str) of - Left err -> handleFailure ("Error parsing command specified in the \ - \stack options comment: " ++ err) + Left err -> handleFailure ("Error parsing command specified in the " + ++ "stack options comment: " ++ err) Right [] -> handleFailure "Empty argument list in stack options comment" Right args -> return args decodeError e = case e of +#if MIN_VERSION_conduit_extra(1,2,0) + ParseError ctxs _ (Position line col _) -> +#else ParseError ctxs _ (Position line col) -> +#endif if null ctxs then "Parse error" else ("Expecting " ++ intercalate " or " ctxs) diff --git a/src/Data/IORef/RunOnce.hs b/src/Data/IORef/RunOnce.hs --- a/src/Data/IORef/RunOnce.hs +++ b/src/Data/IORef/RunOnce.hs @@ -1,16 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Data.IORef.RunOnce (runOnce) where -import Control.Monad.IO.Class -import Data.IORef +import Stack.Prelude -runOnce :: MonadIO m => m a -> m (m a) -runOnce f = do - ref <- liftIO $ newIORef Nothing - return $ do - mval <- liftIO $ readIORef ref +runOnce :: (MonadUnliftIO m, MonadIO n) => m a -> m (n a) +runOnce f = withRunInIO $ \run -> do + ref <- newIORef Nothing + return $ liftIO $ do + mval <- readIORef ref case mval of Just val -> return val Nothing -> do - val <- f - liftIO $ writeIORef ref (Just val) + val <- run f + writeIORef ref (Just val) return val diff --git a/src/Data/Maybe/Extra.hs b/src/Data/Maybe/Extra.hs deleted file mode 100644 --- a/src/Data/Maybe/Extra.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | Extra Maybe utilities. - -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 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/Data/Monoid/Extra.hs b/src/Data/Monoid/Extra.hs deleted file mode 100644 --- a/src/Data/Monoid/Extra.hs +++ /dev/null @@ -1,12 +0,0 @@ --- | Extra Monoid utilities. - -module Data.Monoid.Extra - ( fromFirst - , module Data.Monoid - ) where - -import Data.Maybe -import Data.Monoid - -fromFirst :: a -> First a -> a -fromFirst x = fromMaybe x . getFirst diff --git a/src/Data/Store/VersionTagged.hs b/src/Data/Store/VersionTagged.hs --- a/src/Data/Store/VersionTagged.hs +++ b/src/Data/Store/VersionTagged.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -14,15 +15,9 @@ , storeVersionConfig ) where -import Control.Applicative -import Control.Exception.Lifted (catch, IOException, assert) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger -import Control.Monad.Trans.Control (MonadBaseControl) +import Stack.Prelude import qualified Data.ByteString as BS -import Data.Data (Data) import qualified Data.Map as M -import Data.Monoid ((<>)) import qualified Data.Set as S import Data.Store import Data.Store.Core (unsafeEncodeWith) @@ -31,7 +26,6 @@ import Language.Haskell.TH import Path import Path.IO (ensureDir) -import Prelude versionedEncodeFile :: Data a => VersionConfig a -> Q Exp versionedEncodeFile vc = [e| storeEncodeFile $(encodeWithVersionQ vc) $(decodeWithVersionQ vc) |] @@ -51,17 +45,17 @@ -> m () storeEncodeFile pokeFunc peekFunc fp x = do let fpt = T.pack (toFilePath fp) - $logDebug $ "Encoding " <> fpt + logDebug $ "Encoding " <> fpt ensureDir (parent fp) let (sz, poker) = pokeFunc x encoded = unsafeEncodeWith poker sz assert (decodeExWith peekFunc encoded == x) $ liftIO $ BS.writeFile (toFilePath fp) encoded - $logDebug $ "Finished writing " <> fpt + logDebug $ "Finished writing " <> fpt -- | Read from the given file. If the read fails, run the given action and -- write that back to the file. Always starts the file off with the -- version tag. -versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadIO m, MonadLogger m, MonadBaseControl IO m) +versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadUnliftIO m, MonadLogger m) => (a -> (Int, Poke ())) -> Peek a -> Path Abs File @@ -69,32 +63,32 @@ -> m a versionedDecodeOrLoadImpl pokeFunc peekFunc fp mx = do let fpt = T.pack (toFilePath fp) - $logDebug $ "Trying to decode " <> fpt + logDebug $ "Trying to decode " <> fpt mres <- versionedDecodeFileImpl peekFunc fp case mres of Just x -> do - $logDebug $ "Success decoding " <> fpt + logDebug $ "Success decoding " <> fpt return x _ -> do - $logDebug $ "Failure decoding " <> fpt + logDebug $ "Failure decoding " <> fpt x <- mx storeEncodeFile pokeFunc peekFunc fp x return x -versionedDecodeFileImpl :: (Store a, MonadIO m, MonadLogger m, MonadBaseControl IO m) +versionedDecodeFileImpl :: (Store a, MonadUnliftIO m, MonadLogger m) => Peek a -> Path loc File -> m (Maybe a) versionedDecodeFileImpl peekFunc fp = do mbs <- liftIO (Just <$> BS.readFile (toFilePath fp)) `catch` \(err :: IOException) -> do - $logDebug ("Exception ignored when attempting to load " <> T.pack (toFilePath fp) <> ": " <> T.pack (show err)) + logDebug ("Exception ignored when attempting to load " <> T.pack (toFilePath fp) <> ": " <> T.pack (show err)) return Nothing case mbs of Nothing -> return Nothing Just bs -> liftIO (Just <$> decodeIOWith peekFunc bs) `catch` \(err :: PeekException) -> do let fpt = T.pack (toFilePath fp) - $logDebug ("Error while decoding " <> fpt <> ": " <> T.pack (show err) <> " (this might not be an error, when switching between stack versions)") + logDebug ("Error while decoding " <> fpt <> ": " <> T.pack (show err) <> " (this might not be an error, when switching between stack versions)") return Nothing storeVersionConfig :: String -> String -> VersionConfig a @@ -104,5 +98,15 @@ , "Data.ByteString.Internal.ByteString" ] , vcRenames = M.fromList - [ ( "Data.Maybe.Maybe", "GHC.Base.Maybe") ] + [ ( "Data.Maybe.Maybe", "GHC.Base.Maybe") + , ( "Stack.Types.Compiler.CVActual" + , "Stack.Types.Compiler.'CVActual" + ) + , ( "Stack.Types.Compiler.CVWanted" + , "Stack.Types.Compiler.'CVWanted" + ) + -- moved in containers 0.5.9.1 + , ( "Data.Map.Internal.Map", "Data.Map.Base.Map") + , ( "Data.Set.Internal.Set", "Data.Set.Base.Set") + ] } diff --git a/src/Data/Text/Extra.hs b/src/Data/Text/Extra.hs deleted file mode 100644 --- a/src/Data/Text/Extra.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Data.Text.Extra where - -import Data.Maybe (fromMaybe) -import qualified Data.Text as T - --- | Strip trailing carriage return from Text -stripCR :: T.Text -> T.Text -stripCR t = fromMaybe t (T.stripSuffix "\r" t) diff --git a/src/Distribution/Version/Extra.hs b/src/Distribution/Version/Extra.hs deleted file mode 100644 --- a/src/Distribution/Version/Extra.hs +++ /dev/null @@ -1,30 +0,0 @@ --- A separate module so that we can contain all usage of deprecated identifiers here -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -module Distribution.Version.Extra - ( hasUpper - , hasLower - ) where - -import Distribution.Version (VersionRange (..)) - --- | Does the version range have an upper bound? -hasUpper :: VersionRange -> Bool -hasUpper AnyVersion = False -hasUpper (ThisVersion _) = True -hasUpper (LaterVersion _) = False -hasUpper (EarlierVersion _) = True -hasUpper (WildcardVersion _) = True -hasUpper (UnionVersionRanges x y) = hasUpper x && hasUpper y -hasUpper (IntersectVersionRanges x y) = hasUpper x || hasUpper y -hasUpper (VersionRangeParens x) = hasUpper x - --- | Does the version range have a lower bound? -hasLower :: VersionRange -> Bool -hasLower AnyVersion = False -hasLower (ThisVersion _) = True -hasLower (LaterVersion _) = True -hasLower (EarlierVersion _) = False -hasLower (WildcardVersion _) = True -hasLower (UnionVersionRanges x y) = hasLower x && hasLower y -hasLower (IntersectVersionRanges x y) = hasLower x || hasLower y -hasLower (VersionRangeParens x) = hasLower x diff --git a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs --- a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs +++ b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs @@ -1,3 +1,4 @@ +-- Explicitly disabling due to external code {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs --- a/src/Network/HTTP/Download.hs +++ b/src/Network/HTTP/Download.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} module Network.HTTP.Download ( verifiedDownload , DownloadRequest(..) @@ -20,32 +20,23 @@ , setGithubHeaders ) where -import Control.Exception (Exception) -import Control.Exception.Safe (handleIO) -import Control.Monad (void) -import Control.Monad.Catch (throwM) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger (MonadLogger, logDebug) +import Stack.Prelude +import Stack.Types.Runner import qualified Data.ByteString.Lazy as L -import Data.Conduit (runConduit, runConduitRes, (.|), yield) +import Data.Conduit (yield) import Data.Conduit.Binary (sourceHandle) import qualified Data.Conduit.Binary as CB -import Data.Foldable (forM_) -import Data.Monoid ((<>)) import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding (decodeUtf8With) -import Data.Typeable (Typeable) import Network.HTTP.Client (Request, Response, path, checkResponse, parseUrlThrow, parseRequest) import Network.HTTP.Client.Conduit (requestHeaders) import Network.HTTP.Download.Verified import Network.HTTP.Simple (httpJSON, withResponse, getResponseBody, getResponseHeaders, getResponseStatusCode, setRequestHeader) -import Path (Abs, File, Path, toFilePath) +import Path.IO (doesFileExist) import System.Directory (createDirectoryIfMissing, removeFile) import System.FilePath (takeDirectory, (<.>)) -import System.IO (IOMode (ReadMode), - withBinaryFile) -- | Download the given URL to the given location. If the file already exists, -- no download is performed. Otherwise, creates the parent directory, downloads @@ -53,7 +44,7 @@ -- appropriate destination. -- -- Throws an exception if things go wrong -download :: (MonadIO m, MonadLogger m) +download :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m) => Request -> Path Abs File -- ^ destination -> m Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)? @@ -70,18 +61,22 @@ -- | Same as 'download', but will download a file a second time if it is already present. -- -- Returns 'True' if the file was downloaded, 'False' otherwise -redownload :: (MonadIO m, MonadLogger m) +redownload :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m) => Request -> Path Abs File -- ^ destination -> m Bool redownload req0 dest = do - $logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req0) + logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req0) let destFilePath = toFilePath dest etagFilePath = destFilePath <.> "etag" - metag <- liftIO $ handleIO (const $ return Nothing) $ fmap Just $ - withBinaryFile etagFilePath ReadMode $ \h -> - runConduit $ sourceHandle h .| CB.take 512 + metag <- do + exists <- doesFileExist dest + if not exists + then return Nothing + else liftIO $ handleIO (const $ return Nothing) $ fmap Just $ + withBinaryFile etagFilePath ReadMode $ \h -> + runConduit $ sourceHandle h .| CB.take 512 let req1 = case metag of @@ -92,7 +87,7 @@ [("If-None-Match", L.toStrict etag)] } req2 = req1 { checkResponse = \_ _ -> return () } - liftIO $ recoveringHttp drRetryPolicyDefault $ + recoveringHttp drRetryPolicyDefault $ liftIO $ withResponse req2 $ \res -> case getResponseStatusCode res of 200 -> do createDirectoryIfMissing True $ takeDirectory destFilePath diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -1,14 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} module Network.HTTP.Download.Verified ( verifiedDownload , recoveringHttp @@ -28,35 +27,29 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Control.Applicative import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Logger (logDebug, MonadLogger) -import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay) +import Control.Monad.Catch (Handler (..)) -- would be nice if retry exported this itself +import Stack.Prelude hiding (Handler (..)) +import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay,RetryStatus(..)) import Crypto.Hash import Crypto.Hash.Conduit (sinkHash) import Data.ByteArray as Mem (convert) import Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16)) -import Data.ByteString (ByteString) import Data.ByteString.Char8 (readInteger) import Data.Conduit import Data.Conduit.Binary (sourceHandle, sinkHandle) -import Data.Foldable (traverse_,for_) -import Data.Monoid -import Data.String import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) -import Data.Typeable (Typeable) import GHC.IO.Exception (IOException(..),IOErrorType(..)) import Network.HTTP.Client (getUri, path) import Network.HTTP.Simple (Request, HttpException, httpSink, getResponseHeaders) import Network.HTTP.Types.Header (hContentLength, hContentMD5) import Path -import Prelude -- Fix AMP warning +import Stack.Types.Runner +import Stack.PrettyPrint import System.Directory -import System.FilePath ((<.>)) -import System.IO +import qualified System.FilePath as FP ((<.>)) +import System.IO (hFileSize) -- | A request together with some checks to perform. data DownloadRequest = DownloadRequest @@ -117,7 +110,7 @@ show (WrongDigest req algo expected actual) = "Download expectation failure: content hash (" ++ algo ++ ")\n" ++ "Expected: " ++ displayCheckHexDigest expected ++ "\n" - ++ "Actual: " ++ show actual ++ "\n" + ++ "Actual: " ++ actual ++ "\n" ++ "For: " ++ show (getUri req) instance Exception VerifiedDownloadException @@ -188,20 +181,40 @@ hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req) -- 'Control.Retry.recovering' customized for HTTP failures -recoveringHttp :: (MonadMask m, MonadIO m) +recoveringHttp :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m) => RetryPolicy -> m a -> m a recoveringHttp retryPolicy = #if MIN_VERSION_retry(0,7,0) - recovering retryPolicy handlers . const + helper $ \run -> recovering retryPolicy (handlers run) . const #else - recovering retryPolicy handlers + helper $ \run -> recovering retryPolicy (handlers run) #endif where - handlers = [const $ Handler alwaysRetryHttp,const $ Handler retrySomeIO] + helper :: (MonadUnliftIO m, HasRunner env, MonadReader env m) => (UnliftIO m -> IO a -> IO a) -> m a -> m a + helper wrapper action = withUnliftIO $ \run -> wrapper run (unliftIO run action) - alwaysRetryHttp :: Monad m => HttpException -> m Bool - alwaysRetryHttp _ = return True + handlers :: (MonadLogger m, HasRunner env, MonadReader env m) => UnliftIO m -> [RetryStatus -> Handler IO Bool] + handlers run = [Handler . alwaysRetryHttp (unliftIO run),const $ Handler retrySomeIO] + alwaysRetryHttp :: (MonadLogger m', Monad m, HasRunner env, MonadReader env m') => (m' () -> m ()) -> RetryStatus -> HttpException -> m Bool + alwaysRetryHttp run rs _ = do + run $ + prettyWarn $ vcat + [ flow $ unwords + [ "Retry number" + , show (rsIterNumber rs) + , "after a total delay of" + , show (rsCumulativeDelay rs) + , "us" + ] + , flow $ unwords + [ "If you see this warning and stack fails to download," + , "but running the command again solves the problem," + , "please report here: https://github.com/commercialhaskell/stack/issues/3510" + ] + ] + return True + retrySomeIO :: Monad m => IOException -> m Bool retrySomeIO e = return $ case ioe_type e of -- hGetBuf: resource vanished (Connection reset by peer) @@ -222,7 +235,7 @@ -- Throws VerifiedDownloadException. -- Throws IOExceptions related to file system operations. -- Throws HttpException. -verifiedDownload :: (MonadIO m, MonadLogger m) +verifiedDownload :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m) => DownloadRequest -> Path Abs File -- ^ destination -> (Maybe Integer -> Sink ByteString IO ()) -- ^ custom hook to observe progress @@ -230,20 +243,19 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do let req = drRequest whenM' (liftIO getShouldDownload) $ do - $logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req) - liftIO $ do - createDirectoryIfMissing True dir - recoveringHttp drRetryPolicy $ - withBinaryFile fptmp WriteMode $ \h -> - httpSink req (go h) - renameFile fptmp fp + logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req) + liftIO $ createDirectoryIfMissing True dir + recoveringHttp drRetryPolicy $ liftIO $ + withBinaryFile fptmp WriteMode $ \h -> + httpSink req (go h) + liftIO $ renameFile fptmp fp where whenM' mp m = do p <- mp if p then m >> return True else return False fp = toFilePath destpath - fptmp = fp <.> "tmp" + fptmp = fp FP.<.> "tmp" dir = toFilePath $ parent destpath getShouldDownload = do @@ -261,7 +273,7 @@ `catch` \(_ :: VerifyFileException) -> return False) `catch` \(_ :: VerifiedDownloadException) -> return False - checkExpectations = bracket (openFile fp ReadMode) hClose $ \h -> do + checkExpectations = withBinaryFile fp ReadMode $ \h -> do for_ drLengthCheck $ checkFileSizeExpectations h sourceHandle h $$ getZipSink (hashChecksToZipSink drRequest drHashChecks) diff --git a/src/Options/Applicative/Args.hs b/src/Options/Applicative/Args.hs --- a/src/Options/Applicative/Args.hs +++ b/src/Options/Applicative/Args.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | Accepting arguments to be passed through to a sub-process. @@ -5,39 +6,33 @@ module Options.Applicative.Args (argsArgument ,argsOption - ,cmdOption - ,parseArgsFromString) + ,cmdOption) where import Data.Attoparsec.Args -import qualified Data.Attoparsec.Text as P -import qualified Data.Text as T import qualified Options.Applicative as O +import Stack.Prelude -- | An argument which accepts a list of arguments e.g. @--ghc-options="-X P.hs \"this\""@. argsArgument :: O.Mod O.ArgumentFields [String] -> O.Parser [String] argsArgument = O.argument (do string <- O.str - either O.readerError return (parseArgsFromString string)) + either O.readerError return (parseArgsFromString Escaping string)) -- | An option which accepts a list of arguments e.g. @--ghc-options="-X P.hs \"this\""@. argsOption :: O.Mod O.OptionFields [String] -> O.Parser [String] argsOption = O.option (do string <- O.str - either O.readerError return (parseArgsFromString string)) + either O.readerError return (parseArgsFromString Escaping string)) -- | An option which accepts a command and a list of arguments e.g. @--exec "echo hello world"@ cmdOption :: O.Mod O.OptionFields (String, [String]) -> O.Parser (String, [String]) cmdOption = O.option (do string <- O.str - xs <- either O.readerError return (parseArgsFromString string) + xs <- either O.readerError return (parseArgsFromString Escaping string) case xs of [] -> O.readerError "Must provide a command" x:xs' -> return (x, xs')) - --- | Parse from a string. -parseArgsFromString :: String -> Either String [String] -parseArgsFromString = P.parseOnly (argsParser Escaping) . T.pack diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs --- a/src/Options/Applicative/Builder/Extra.hs +++ b/src/Options/Applicative/Builder/Extra.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -29,17 +30,14 @@ ,unescapeBashArg ) where -import Control.Exception (IOException, catch) -import Control.Monad (when, forM) -import Data.Either.Combinators import Data.List (isPrefixOf) import Data.Maybe import Data.Monoid -import Data.Text (Text) import qualified Data.Text as T import Options.Applicative import Options.Applicative.Types (readerAsk) import Path hiding (()) +import Stack.Prelude import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist) import System.Environment (withArgs) import System.FilePath (takeBaseName, (), splitFileName, isRelative, takeExtension) @@ -110,6 +108,11 @@ (long ("[no-]" ++ name) <> help ("Enable/disable " ++ helpSuffix) <> mods)) + where + last xs = + case reverse xs of + [] -> impureThrow $ stringException "enableDisableFlagsNoDefault.last" + x:_ -> x -- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args). -- @@ -141,7 +144,7 @@ _ <- execParser (info (hiddenHelper <*> ((,) <$> parser <*> - some (strArgument (metavar "OTHER ARGUMENTS")))) + some (strArgument (metavar "OTHER ARGUMENTS") :: Parser String))) (fullDesc <> progDesc pd)) return () where hiddenHelper = abortOption ShowHelpText (long "help" <> hidden <> internal) @@ -244,9 +247,10 @@ unescapeBashArg ('\'' : rest) = rest unescapeBashArg ('\"' : rest) = go rest where + pattern = "$`\"\\\n" :: String go [] = [] go ('\\' : x : xs) - | x `elem` "$`\"\\\n" = x : xs + | x `elem` pattern = x : xs | otherwise = '\\' : x : go xs go (x : xs) = x : go xs unescapeBashArg input = go input diff --git a/src/Options/Applicative/Complicated.hs b/src/Options/Applicative/Complicated.hs --- a/src/Options/Applicative/Complicated.hs +++ b/src/Options/Applicative/Complicated.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} -- | Simple interface to complicated program arguments. -- -- This is a "fork" of the @optparse-simple@ package that has some workarounds for @@ -12,14 +13,13 @@ , complicatedParser ) where -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Either +import Control.Monad.Trans.Except import Control.Monad.Trans.Writer -import Data.Monoid import Data.Version import Options.Applicative import Options.Applicative.Types import Options.Applicative.Builder.Internal +import Stack.Prelude import System.Environment -- | Generate and execute a complicated options parser. @@ -42,7 +42,7 @@ -> Maybe (ParserFailure ParserHelp -> [String] -> IO (a,(b,a))) -- ^ optional handler for parser failure; 'handleParseResult' is called by -- default - -> EitherT b (Writer (Mod CommandFields (b,a))) () + -> ExceptT b (Writer (Mod CommandFields (b,a))) () -- ^ commands (use 'addCommand') -> IO (a,b) complicatedOptions numericVersion versionString numericHpackVersion h pd footerStr commonParser mOnFailure commandParser = @@ -82,7 +82,7 @@ -> (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))) () + -> ExceptT b (Writer (Mod CommandFields (b,c))) () addCommand cmd title footerStr constr = addCommand' cmd title footerStr (\a c -> (constr a,c)) @@ -97,9 +97,9 @@ -- ^ footer of command help -> Parser c -- ^ common parser - -> EitherT b (Writer (Mod CommandFields (b,c))) () + -> ExceptT b (Writer (Mod CommandFields (b,c))) () -- ^ sub-commands (use 'addCommand') - -> EitherT b (Writer (Mod CommandFields (b,c))) () + -> ExceptT b (Writer (Mod CommandFields (b,c))) () addSubCommands cmd title footerStr commonParser commandParser = addCommand' cmd title @@ -115,7 +115,7 @@ -> (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))) () + -> ExceptT b (Writer (Mod CommandFields (b,c))) () addCommand' cmd title footerStr constr commonParser inner = lift (tell (command cmd (info (constr <$> inner <*> commonParser) @@ -128,13 +128,13 @@ -- ^ metavar for the sub-command -> Parser a -- ^ common settings - -> EitherT b (Writer (Mod CommandFields (b,a))) () + -> ExceptT b (Writer (Mod CommandFields (b,a))) () -- ^ commands (use 'addCommand') -> Parser (a,(b,a)) complicatedParser commandMetavar commonParser commandParser = (,) <$> commonParser <*> - case runWriter (runEitherT commandParser) of + case runWriter (runExceptT commandParser) of (Right (),d) -> hsubparser' commandMetavar d (Left b,_) -> pure (b,mempty) diff --git a/src/Path/CheckInstall.hs b/src/Path/CheckInstall.hs --- a/src/Path/CheckInstall.hs +++ b/src/Path/CheckInstall.hs @@ -1,23 +1,21 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module Path.CheckInstall where -import Control.Monad (unless) import Control.Monad.Extra (anyM, (&&^)) -import Control.Monad.IO.Class -import Control.Monad.Logger -import Data.Foldable (forM_) -import Data.Text (Text) import qualified Data.Text as T +import Stack.Prelude +import Stack.PrettyPrint +import Stack.Types.Config import qualified System.Directory as D import qualified System.FilePath as FP -- | Checks if the installed executable will be available on the user's -- PATH. This doesn't use @envSearchPath menv@ because it includes paths -- only visible when running in the stack environment. -warnInstallSearchPathIssues :: (MonadIO m, MonadLogger m) => FilePath -> [Text] -> m () +warnInstallSearchPathIssues :: HasConfig env => FilePath -> [Text] -> RIO env () warnInstallSearchPathIssues destDir installed = do searchPath <- liftIO FP.getSearchPath destDirIsInPATH <- liftIO $ @@ -29,32 +27,27 @@ Just exePath -> do exeDir <- (liftIO . fmap FP.takeDirectory . D.canonicalizePath) exePath unless (exeDir `FP.equalFilePath` destDir) $ do - $logWarn "" - $logWarn $ T.concat - [ "WARNING: The \"" - , exe - , "\" executable found on the PATH environment variable is " - , T.pack exePath - , ", and not the version that was just installed." - ] - $logWarn $ T.concat - [ "This means that \"" - , exe - , "\" calls on the command line will not use this version." - ] + prettyWarnL + [ flow "The" + , styleFile . fromString . T.unpack $ exe + , flow "executable found on the PATH environment variable is" + , styleFile . fromString $ exePath + , flow "and not the version that was just installed." + , flow "This means that" + , styleFile . fromString . T.unpack $ exe + , "calls on the command line will not use this version." + ] Nothing -> do - $logWarn "" - $logWarn $ T.concat - [ "WARNING: Installation path " - , T.pack destDir - , " is on the PATH but the \"" - , exe - , "\" executable that was just installed could not be found on the PATH." - ] + prettyWarnL + [ flow "Installation path" + , styleDir . fromString $ destDir + , flow "is on the PATH but the" + , styleFile . fromString . T.unpack $ exe + , flow "executable that was just installed could not be found on the PATH." + ] else do - $logWarn "" - $logWarn $ T.concat - [ "WARNING: Installation path " - , T.pack destDir - , " not found on the PATH environment variable" - ] + prettyWarnL + [ flow "Installation path " + , styleDir . fromString $ destDir + , "not found on the PATH environment variable." + ] diff --git a/src/Path/Extra.hs b/src/Path/Extra.hs --- a/src/Path/Extra.hs +++ b/src/Path/Extra.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ViewPatterns #-} -- | Extra Path utilities. @@ -13,19 +14,20 @@ ,pathToByteString ,pathToLazyByteString ,pathToText + ,tryGetModificationTime ) where -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.ByteString.Char8 as BS -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Control.Monad (liftM) -import Control.Monad.Catch -import Control.Monad.IO.Class import Data.Bool (bool) +import Data.Time (UTCTime) import Path import Path.IO import Path.Internal (Path(..)) +import Stack.Prelude +import System.IO.Error (isDoesNotExistError) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified System.FilePath as FP -- | Convert to FilePath but don't add a trailing slash. @@ -62,7 +64,7 @@ -- -- (adapted from @Text.Pandoc.Shared@) collapseFilePath :: FilePath -> FilePath -collapseFilePath = FP.joinPath . reverse . foldl go [] . FP.splitDirectories +collapseFilePath = FP.joinPath . reverse . foldl' go [] . FP.splitDirectories where go rs "." = rs go r@(p:rs) ".." = case p of @@ -117,3 +119,6 @@ pathToText :: Path b t -> T.Text pathToText = T.pack . toFilePath + +tryGetModificationTime :: MonadIO m => Path Abs File -> m (Either () UTCTime) +tryGetModificationTime = liftIO . tryJust (guard . isDoesNotExistError) . getModificationTime diff --git a/src/Path/Find.hs b/src/Path/Find.hs --- a/src/Path/Find.hs +++ b/src/Path/Find.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} -- | Finding files. @@ -9,11 +10,7 @@ ,findInParents) where -import Control.Exception (evaluate) -import Control.DeepSeq (force) -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class +import Stack.Prelude import System.IO.Error (isPermissionError) import Data.List import Path diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -20,37 +21,21 @@ ,CabalVersionException(..)) where -import Control.Exception (Exception) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Reader (MonadReader) -import Control.Monad.Trans.Resource -import Control.Monad.Trans.Unlift (MonadBaseUnlift) +import Stack.Prelude import Data.Aeson (Value (Object, Array), (.=), object) -import Data.Function import qualified Data.HashMap.Strict as HM import Data.List ((\\)) import Data.List.Extra (groupSort) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map -import Data.Map.Strict (Map) -import Data.Maybe (catMaybes) -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as Set -import Data.String -import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.IO as TIO import Data.Text.Read (decimal) -import Data.Typeable (Typeable) import qualified Data.Vector as V import qualified Data.Yaml as Yaml -import Path -import Prelude hiding (FilePath, writeFile) import Stack.Build.ConstructPlan import Stack.Build.Execute import Stack.Build.Haddock @@ -59,16 +44,14 @@ import Stack.Build.Target import Stack.Fetch as Fetch import Stack.Package -import Stack.PackageIndex -import Stack.PrettyPrint +import Stack.PackageLocation (parseSingleCabalFileIndex) import Stack.Types.Build +import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT -import Stack.Types.StringError import Stack.Types.Version #ifdef WINDOWS @@ -78,7 +61,6 @@ #ifdef WINDOWS import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP) -import qualified Control.Monad.Catch as Catch #endif -- | Build. @@ -86,25 +68,31 @@ -- If a buildLock is passed there is an important contract here. That lock must -- protect the snapshot, and it must be safe to unlock it if there are no further -- modifications to the snapshot to be performed by this build. -build :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) +build :: HasEnvConfig env => (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files -> Maybe FileLock -> BuildOptsCLI - -> m () + -> RIO env () build setLocalFiles mbuildLk boptsCli = fixCodePage $ do bopts <- view buildOptsL let profiling = boptsLibProfile bopts || boptsExeProfile bopts let symbols = not (boptsLibStrip bopts || boptsExeStrip bopts) menv <- getMinimalEnvOverride - (targets, mbp, locals, extraToBuild, extraDeps, sourceMap) <- loadSourceMapFull NeedTargets boptsCli + (targets, mbp, locals, extraToBuild, sourceMap) <- loadSourceMapFull NeedTargets boptsCli -- Set local files, necessary for file watching stackYaml <- view stackYamlL liftIO $ setLocalFiles $ Set.insert stackYaml $ Set.unions - $ map lpFiles locals + -- The `locals` value above only contains local project + -- packages, not local dependencies. This will get _all_ + -- of the local files we're interested in + -- watching. Arguably, we should not bother watching repo + -- and archive files, since those shouldn't + -- change. That's a possible optimization to consider. + [lpFiles lp | PSFiles lp _ <- Map.elems sourceMap] (installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <- getInstalled menv @@ -114,8 +102,6 @@ , getInstalledSymbols = symbols } sourceMap - warnMissingExtraDeps installedMap extraDeps - baseConfigOpts <- mkBaseConfigOpts boptsCli plan <- withLoadPackage $ \loadPackage -> constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli) @@ -131,7 +117,7 @@ -- NOTE: This policy is too conservative. In the future we should be able to -- schedule unlocking as an Action that happens after all non-local actions are -- complete. - (Just lk,True) -> do $logDebug "All installs are local; releasing snapshot lock early." + (Just lk,True) -> do logDebug "All installs are local; releasing snapshot lock early." liftIO $ unlockFile lk _ -> return () @@ -167,7 +153,7 @@ Map.elems . planTasks -checkCabalVersion :: (StackM env m, HasEnvConfig env) => m () +checkCabalVersion :: HasEnvConfig env => RIO env () checkCabalVersion = do allowNewer <- view $ configL.to configAllowNewer cabalVer <- view cabalVersionL @@ -184,30 +170,11 @@ instance Show CabalVersionException where show = unCabalVersionException instance Exception CabalVersionException -warnMissingExtraDeps - :: (StackM env m, HasConfig env) - => InstalledMap -> Map PackageName Version -> m () -warnMissingExtraDeps installed extraDeps = do - missingExtraDeps <- - fmap catMaybes $ forM (Map.toList extraDeps) $ \(n, v) -> - if Map.member n installed - then return Nothing - else do - vs <- getPackageVersions n - if Set.null vs - then return $ Just $ - fromString (packageNameString n ++ "-" ++ versionString v) - else return Nothing - unless (null missingExtraDeps) $ - $prettyWarn $ - "Some extra-deps are neither installed nor in the index:" <> line <> - indent 4 (bulletedList missingExtraDeps) - -- | See https://github.com/commercialhaskell/stack/issues/1198. warnIfExecutablesWithSameNameCouldBeOverwritten :: MonadLogger m => [LocalPackage] -> Plan -> m () warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do - $logDebug "Checking if we are going to build multiple executables with the same name" + logDebug "Checking if we are going to build multiple executables with the same name" forM_ (Map.toList warnings) $ \(exe,(toBuild,otherLocals)) -> do let exe_s | length toBuild > 1 = "several executables with the same name:" @@ -216,7 +183,7 @@ T.intercalate ", " ["'" <> packageNameText p <> ":" <> exe <> "'" | p <- pkgs] - ($logWarn . T.unlines . concat) + (logWarn . T.unlines . concat) [ [ "Building " <> exe_s <> " " <> exesText toBuild <> "." ] , [ "Only one of them will be available via 'stack exec' or locally installed." | length toBuild > 1 @@ -259,14 +226,9 @@ collect [ (exe,pkgName) | (pkgName,task) <- Map.toList (planTasks plan) - , isLocal task - , exe <- (Set.toList . exeComponents . lpComponents . taskLP) task + , TTFiles lp _ <- [taskType task] -- FIXME analyze logic here, do we need to check for Local? + , exe <- (Set.toList . exeComponents . lpComponents) lp ] - where - isLocal Task{taskType = (TTLocal _)} = True - isLocal _ = False - taskLP Task{taskType = (TTLocal lp)} = lp - taskLP _ = error "warnIfExecutablesWithSameNameCouldBeOverwritten/taskLP: task isn't local" localExes :: Map Text (NonEmpty PackageName) localExes = collect @@ -279,7 +241,7 @@ warnAboutSplitObjs :: MonadLogger m => BuildOpts -> m () warnAboutSplitObjs bopts | boptsSplitObjs bopts = do - $logWarn $ "Building with --split-objs is enabled. " <> T.pack splitObjsWarning + logWarn $ "Building with --split-objs is enabled. " <> T.pack splitObjsWarning warnAboutSplitObjs _ = return () splitObjsWarning :: String @@ -311,23 +273,18 @@ } -- | Provide a function for loading package information from the package index -withLoadPackage :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) - => ((PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -> m a) - -> m a +withLoadPackage :: HasEnvConfig env + => ((PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) -> RIO env a) + -> RIO env a withLoadPackage inner = do econfig <- view envConfigL - withCabalLoader $ \cabalLoader -> - inner $ \name version flags ghcOptions -> do - bs <- cabalLoader $ PackageIdentifier name version - - -- Intentionally ignore warnings, as it's not really - -- appropriate to print a bunch of warnings out while - -- resolving the package index. - (_warnings,pkg) <- readPackageBS + root <- view projectRootL + run <- askRunInIO + withCabalLoader $ \loadFromIndex -> + inner $ \loc flags ghcOptions -> run $ + resolvePackage (depPackageConfig econfig flags ghcOptions) - (PackageIdentifier name version) - bs - return pkg + <$> parseSingleCabalFileIndex loadFromIndex root loc where -- | Package config to be used for dependencies depPackageConfig :: EnvConfig -> Map FlagName Bool -> [Text] -> PackageConfig @@ -342,8 +299,8 @@ -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738 +fixCodePage :: HasEnvConfig env => RIO env a -> RIO env a #ifdef WINDOWS -fixCodePage :: (StackM env m, HasBuildConfig env, HasEnvConfig env) => m a -> m a fixCodePage inner = do mcp <- view $ configL.to configModifyCodePage ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion @@ -359,13 +316,13 @@ let setInput = origCPI /= expected setOutput = origCPO /= expected fixInput - | setInput = Catch.bracket_ + | setInput = bracket_ (liftIO $ do setConsoleCP expected) (liftIO $ setConsoleCP origCPI) | otherwise = id fixOutput - | setOutput = Catch.bracket_ + | setOutput = bracket_ (liftIO $ do setConsoleOutputCP expected) (liftIO $ setConsoleOutputCP origCPO) @@ -379,20 +336,19 @@ fixInput $ fixOutput inner expected = 65001 -- UTF-8 - warn typ = $logInfo $ T.concat + warn typ = logInfo $ T.concat [ "Setting" , typ , " codepage to UTF-8 (65001) to ensure correct output from GHC" ] #else -fixCodePage :: a -> a fixCodePage = id #endif -- | Query information about the build and print the result to stdout in YAML format. -queryBuildInfo :: (StackM env m, HasEnvConfig env) +queryBuildInfo :: HasEnvConfig env => [Text] -- ^ selectors - -> m () + -> RIO env () queryBuildInfo selectors0 = rawBuildInfo >>= select id selectors0 @@ -414,10 +370,10 @@ _ -> err $ "Cannot apply selector to " ++ show value where cont = select (front . (sel:)) sels - err msg = errorString $ msg ++ ": " ++ show (front [sel]) + err msg = throwString $ msg ++ ": " ++ show (front [sel]) -- | Get the raw build information object -rawBuildInfo :: (StackM env m, HasEnvConfig env) => m Value +rawBuildInfo :: HasEnvConfig env => RIO env Value rawBuildInfo = do (locals, _sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI return $ object diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} @@ -31,48 +32,31 @@ , BuildCache(..) ) where -import Control.Applicative -import Control.DeepSeq (NFData) -import Control.Exception.Safe (handleIO, tryAnyDeep) -import Control.Monad (liftM) -import Control.Monad.Catch (MonadThrow, MonadCatch) -import Control.Monad.IO.Class -import Control.Monad.Logger (MonadLogger) -import Control.Monad.Reader (MonadReader) -import Control.Monad.Trans.Control (MonadBaseControl) +import Stack.Prelude import Crypto.Hash (hashWith, SHA256(..)) -import Data.Binary (Binary (..)) -import qualified Data.Binary as Binary -import Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion) -import qualified Data.Binary.Tagged as BinaryTagged +import Control.Monad.Trans.Maybe import qualified Data.ByteArray as Mem (convert) -import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16)) import qualified Data.ByteString.Base64.URL as B64URL +import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as LBS -import Data.Foldable (forM_) -import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Store as Store import Data.Store.VersionTagged -import Data.Text (Text) import qualified Data.Text as T -import Data.Traversable (forM) +import qualified Data.Text.Encoding as TE import Path import Path.IO -import Prelude -- Fix redundant import warnings -import Stack.Constants +import Stack.Constants.Config import Stack.Types.Build +import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.Version -import qualified System.FilePath as FilePath +import qualified System.FilePath as FP -- | Directory containing files to mark an executable as installed exeInstalledDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m) @@ -97,7 +81,7 @@ mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files -- | Mark the given executable as installed -markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadCatch m) +markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m) => InstallLocation -> PackageIdentifier -> m () markExeInstalled loc ident = do dir <- exeInstalledDir loc @@ -112,28 +96,28 @@ -- TODO consideration for the future: list all of the executables -- installed, and invalidate this file in getInstalledExes if they no -- longer exist - liftIO $ writeFile fp "Installed" + liftIO $ B.writeFile fp "Installed" -- | Mark the given executable as not installed -markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadCatch m) +markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m) => InstallLocation -> PackageIdentifier -> m () markExeNotInstalled loc ident = do dir <- exeInstalledDir loc ident' <- parseRelFile $ packageIdentifierString ident - ignoringAbsence (removeFile $ dir ident') + liftIO $ ignoringAbsence (removeFile $ dir ident') -- | Try to read the dirtiness cache for the given package directory. -tryGetBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, MonadLogger m, HasEnvConfig env, MonadBaseControl IO m) +tryGetBuildCache :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, MonadLogger m, HasEnvConfig env) => Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo)) tryGetBuildCache dir = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir -- | Try to read the dirtiness cache for the given package directory. -tryGetConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m) +tryGetConfigCache :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) => Path Abs Dir -> m (Maybe ConfigCache) tryGetConfigCache dir = $(versionedDecodeFile configCacheVC) =<< configCacheFile dir -- | Try to read the mod time of the cabal file from the last build -tryGetCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m) +tryGetCabalMod :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) => Path Abs Dir -> m (Maybe ModTime) tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir @@ -165,7 +149,7 @@ $(versionedEncodeFile modTimeVC) fp x -- | Delete the caches for the project. -deleteCaches :: (MonadIO m, MonadReader env m, MonadCatch m, HasEnvConfig env) +deleteCaches :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m) => Path Abs Dir -> m () deleteCaches dir = do {- FIXME confirm that this is acceptable to remove @@ -173,7 +157,7 @@ removeFileIfExists bfp -} cfp <- configCacheFile dir - ignoringAbsence (removeFile cfp) + liftIO $ ignoringAbsence (removeFile cfp) flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) => Installed @@ -181,13 +165,13 @@ flagCacheFile installed = do rel <- parseRelFile $ case installed of - Library _ gid -> ghcPkgIdString gid + Library _ gid _ -> ghcPkgIdString gid Executable ident -> packageIdentifierString ident dir <- flagCacheLocal return $ dir rel -- | Loads the flag cache for the given installed extra-deps -tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m) +tryGetFlagCache :: (MonadUnliftIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) => Installed -> m (Maybe ConfigCache) tryGetFlagCache gid = do @@ -220,7 +204,7 @@ $(versionedEncodeFile testSuccessVC) fp False -- | Check if the test suite already passed -checkTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m) +checkTestSuccess :: (MonadUnliftIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) => Path Abs Dir -> m Bool checkTestSuccess dir = @@ -246,60 +230,77 @@ -- We only pay attention to non-directory options. We don't want to avoid a -- cache hit just because it was installed in a different directory. precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) - => PackageIdentifier + => PackageLocationIndex FilePath -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies - -> m (Path Abs File, m (Path Abs File)) -precompiledCacheFile pkgident copts installedPackageIDs = do - ec <- view envConfigL + -> m (Maybe (Path Abs File)) +precompiledCacheFile loc copts installedPackageIDs = do + ec <- view envConfigL - compiler <- view actualCompilerVersionL >>= parseRelDir . compilerVersionString - cabal <- view cabalVersionL >>= parseRelDir . versionString - pkg <- parseRelDir $ packageIdentifierString pkgident - platformRelDir <- platformGhcRelDir + compiler <- view actualCompilerVersionL >>= parseRelDir . compilerVersionString + cabal <- view cabalVersionL >>= parseRelDir . versionString + let mpkgRaw = + -- The goal here is to come up with a string representing the + -- package location which is unique. For archives and repos, + -- we rely upon cryptographic hashes paired with + -- subdirectories to identify this specific package version. + case loc of + PLIndex pir -> Just $ packageIdentifierRevisionString pir + PLOther other -> case other of + PLFilePath _ -> assert False Nothing -- no PLFilePaths should end up in a snapshot + PLArchive a -> fmap + (\h -> T.unpack (staticSHA256ToText h) ++ archiveSubdirs a) + (archiveHash a) + PLRepo r -> Just $ T.unpack (repoCommit r) ++ repoSubdirs r - let input = (coNoDirs copts, installedPackageIDs) + forM mpkgRaw $ \pkgRaw -> do + pkg <- + case parseRelDir pkgRaw of + Just x -> return x + Nothing -> parseRelDir + $ T.unpack + $ TE.decodeUtf8 + $ B64URL.encode + $ TE.encodeUtf8 + $ T.pack pkgRaw + platformRelDir <- platformGhcRelDir -- In Cabal versions 1.22 and later, the configure options contain the -- installed package IDs, which is what we need for a unique hash. -- Unfortunately, earlier Cabals don't have the information, so we must -- supplement it with the installed package IDs directly. -- See issue: https://github.com/commercialhaskell/stack/issues/1103 - let oldHash = Mem.convertToBase Mem.Base16 $ hashWith SHA256 $ LBS.toStrict $ - if view cabalVersionL ec >= $(mkVersion "1.22") - then Binary.encode (coNoDirs copts) - else Binary.encode input - hashToPath hash = do - hashPath <- parseRelFile $ S8.unpack hash - return $ view stackRootL ec - $(mkRelDir "precompiled") - platformRelDir - compiler - cabal - pkg - hashPath + let input = (coNoDirs copts, installedPackageIDs) + hashPath <- parseRelFile $ S8.unpack $ B64URL.encode + $ Mem.convert $ hashWith SHA256 $ Store.encode input - newPath <- hashToPath $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ Store.encode input - return (newPath, hashToPath oldHash) + return $ view stackRootL ec + $(mkRelDir "precompiled") + platformRelDir + compiler + cabal + pkg + hashPath -- | Write out information about a newly built package writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m) => BaseConfigOpts - -> PackageIdentifier + -> PackageLocationIndex FilePath -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies -> Installed -- ^ library -> Set Text -- ^ executables -> m () -writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do - (file, _) <- precompiledCacheFile pkgident copts depIDs +writePrecompiledCache baseConfigOpts loc copts depIDs mghcPkgId exes = do + mfile <- precompiledCacheFile loc copts depIDs + forM_ mfile $ \file -> do ensureDir (parent file) ec <- view envConfigL let stackRootRelative = makeRelative (view stackRootL ec) mlibpath <- case mghcPkgId of Executable _ -> return Nothing - Library _ ipid -> liftM Just $ do + Library _ ipid _ -> liftM Just $ do ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf" relPath <- stackRootRelative $ bcoSnapDB baseConfigOpts ipid' return $ toFilePath relPath @@ -314,46 +315,27 @@ -- | Check the cache for a precompiled package matching the given -- configuration. -readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m, MonadBaseControl IO m) - => PackageIdentifier -- ^ target package +readPrecompiledCache :: forall env. HasEnvConfig env + => PackageLocationIndex FilePath -- ^ target package -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies - -> m (Maybe PrecompiledCache) -readPrecompiledCache pkgident copts depIDs = do - ec <- view envConfigL - let toAbsPath path = do - if FilePath.isAbsolute path - then path -- Only older version store absolute path - else toFilePath (view stackRootL ec) FilePath. path - let toAbsPC pc = - PrecompiledCache - { pcLibrary = fmap toAbsPath (pcLibrary pc) - , pcExes = map toAbsPath (pcExes pc) - } - - (file, getOldFile) <- precompiledCacheFile pkgident copts depIDs - mres <- $(versionedDecodeFile precompiledCacheVC) file - case mres of - Just res -> return (Just $ toAbsPC res) - Nothing -> do - -- Fallback on trying the old binary format. - oldFile <- getOldFile - mpc <- fmap toAbsPC <$> binaryDecodeFileOrFailDeep oldFile - -- Write out file in new format. Keep old file around for - -- the benefit of older stack versions. - forM_ mpc ($(versionedEncodeFile precompiledCacheVC) file) - return mpc - --- | Ensure that there are no lurking exceptions deep inside the parsed --- value... because that happens unfortunately. See --- https://github.com/commercialhaskell/stack/issues/554 -binaryDecodeFileOrFailDeep :: (BinarySchema a, MonadIO m) - => Path loc File - -> m (Maybe a) -binaryDecodeFileOrFailDeep fp = liftIO $ fmap (either (const Nothing) id) $ tryAnyDeep $ do - eres <- BinaryTagged.taggedDecodeFileOrFail (toFilePath fp) - case eres of - Left _ -> return Nothing - Right x -> return (Just x) - -type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a) + -> RIO env (Maybe PrecompiledCache) +readPrecompiledCache loc copts depIDs = runMaybeT $ + MaybeT (precompiledCacheFile loc copts depIDs) >>= + MaybeT . $(versionedDecodeFile precompiledCacheVC) >>= + lift . mkAbs + where + -- Since commit ed9ccc08f327bad68dd2d09a1851ce0d055c0422, + -- pcLibrary paths are stored as relative to the stack + -- root. Therefore, we need to prepend the stack root when + -- checking that the file exists. For the older cached paths, the + -- file will contain an absolute path, which will make `stackRoot + -- ` a no-op. + mkAbs :: PrecompiledCache -> RIO env PrecompiledCache + mkAbs pc0 = do + stackRoot <- view stackRootL + let mkAbs' = (toFilePath stackRoot FP.) + return PrecompiledCache + { pcLibrary = mkAbs' <$> pcLibrary pc0 + , pcExes = mkAbs' <$> pcExes pc0 + } diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -17,49 +18,36 @@ ( constructPlan ) where -import Control.Exception.Lifted -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Logger +import Stack.Prelude import Control.Monad.RWS.Strict import Control.Monad.State.Strict (execState) -import Control.Monad.Trans.Resource -import Data.Either -import Data.Function import qualified Data.HashSet as HashSet import Data.List import Data.List.Extra (nubOrd) -import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Set (Set) import qualified Data.Set as Set -import Data.String (fromString) -import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) -import Data.Typeable -import qualified Distribution.Package as Cabal import qualified Distribution.Text as Cabal import qualified Distribution.Version as Cabal -import GHC.Generics (Generic) +import Distribution.Types.BuildType (BuildType (Configure)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Lens.Micro (lens) -import Path -import Prelude hiding (pi, writeFile) import Stack.Build.Cache import Stack.Build.Haddock import Stack.Build.Installed import Stack.Build.Source import Stack.BuildPlan +import Stack.Config (getLocalPackages) import Stack.Constants import Stack.Package import Stack.PackageDump import Stack.PackageIndex import Stack.PrettyPrint import Stack.Types.Build +import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName @@ -67,8 +55,9 @@ import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT (StackM) +import Stack.Types.Runner import Stack.Types.Version +import System.IO (putStrLn) import System.Process.Read (findExecutable) data PackageInfo @@ -129,29 +118,32 @@ mempty = memptydefault mappend = mappenddefault -type M = RWST +type M = RWST -- TODO replace with more efficient WS stack on top of StackT Ctx W (Map PackageName (Either ConstructPlanException AddDepRes)) IO data Ctx = Ctx - { mbp :: !MiniBuildPlan + { ls :: !LoadedSnapshot , baseConfigOpts :: !BaseConfigOpts - , loadPackage :: !(PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) + , loadPackage :: !(PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) , combinedMap :: !CombinedMap - , toolToPackages :: !(Cabal.Dependency -> Map PackageName VersionRange) + , toolToPackages :: !(ExeName -> Map PackageName VersionRange) , ctxEnvConfig :: !EnvConfig , callStack :: ![PackageName] , extraToBuild :: !(Set PackageName) , getVersions :: !(PackageName -> IO (Set Version)) , wanted :: !(Set PackageName) , localNames :: !(Set PackageName) - , logFunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO () } instance HasPlatform Ctx instance HasGHCVariant Ctx +instance HasLogFunc Ctx where + logFuncL = configL.logFuncL +instance HasRunner Ctx where + runnerL = configL.runnerL instance HasConfig Ctx instance HasBuildConfig Ctx instance HasEnvConfig Ctx where @@ -173,30 +165,31 @@ -- -- 3) It will only rebuild a local package if its files are dirty or -- some of its dependencies have changed. -constructPlan :: forall env m. (StackM env m, HasEnvConfig env) - => MiniBuildPlan +constructPlan :: forall env. HasEnvConfig env + => LoadedSnapshot -> BaseConfigOpts -> [LocalPackage] -> Set PackageName -- ^ additional packages that must be built -> [DumpPackage () () ()] -- ^ locally registered - -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package + -> (PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package -> SourceMap -> InstalledMap -> Bool - -> m Plan -constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = do - $logDebug "Constructing the build plan" - getVersions0 <- getPackageVersionsIO + -> RIO env Plan +constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = do + logDebug "Constructing the build plan" + u <- askUnliftIO econfig <- view envConfigL let onWanted = void . addDep False . packageName . lpPackage let inner = do mapM_ onWanted $ filter lpWanted locals mapM_ (addDep False) $ Set.toList extraToBuild0 - lf <- askLoggerIO + lp <- getLocalPackages + let ctx = mkCtx econfig (unliftIO u . getPackageVersions) lp ((), m, W efinals installExes dirtyReason deps warnings parents) <- - liftIO $ runRWST inner (ctx econfig getVersions0 lf) M.empty - mapM_ $logWarn (warnings []) + liftIO $ runRWST inner ctx M.empty + mapM_ logWarn (warnings []) let toEither (_, Left e) = Left e toEither (k, Right v) = Right (k, v) (errlibs, adrs) = partitionEithers $ map toEither $ M.toList m @@ -217,36 +210,34 @@ , planFinals = M.fromList finals , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps , planInstallExes = - if boptsInstallExes $ bcoBuildOpts baseConfigOpts0 + if boptsInstallExes (bcoBuildOpts baseConfigOpts0) || + boptsInstallCompilerTool (bcoBuildOpts baseConfigOpts0) then installExes else Map.empty } else do planDebug $ show errs stackYaml <- view stackYamlL - $prettyError $ pprintExceptions errs stackYaml parents (wantedLocalPackages locals) + prettyErrorNoIndent $ pprintExceptions errs stackYaml parents (wanted ctx) throwM $ ConstructPlanFailed "Plan construction failed." where - ctx econfig getVersions0 lf = Ctx - { mbp = mbp0 + mkCtx econfig getVersions0 lp = Ctx + { ls = ls0 , baseConfigOpts = baseConfigOpts0 , loadPackage = loadPackage0 , combinedMap = combineMap sourceMap installedMap - , toolToPackages = \(Cabal.Dependency name _) -> + , toolToPackages = \name -> maybe Map.empty (Map.fromSet (const Cabal.anyVersion)) $ - Map.lookup (T.pack . packageNameString . fromCabalPackageName $ name) toolMap + Map.lookup name toolMap , ctxEnvConfig = econfig , callStack = [] , extraToBuild = extraToBuild0 , getVersions = getVersions0 , wanted = wantedLocalPackages locals <> extraToBuild0 , localNames = Set.fromList $ map (packageName . lpPackage) locals - , logFunc = lf } - -- TODO Currently, this will only consider and install tools from the - -- snapshot. It will not automatically install build tools from extra-deps - -- or local packages. - toolMap = getToolMap mbp0 + where + toolMap = getToolMap ls0 lp -- | State to be maintained during the calculation of local packages -- to unregister. @@ -319,7 +310,7 @@ then Nothing else Just $ fromMaybe "" $ Map.lookup name dirtyReason -- Check if we're no longer using the local version - | Just (PSUpstream _ Snap _ _ _) <- Map.lookup name sourceMap + | Just (piiLocation -> Snap) <- Map.lookup name sourceMap = Just "Switching to snapshot installed package" -- Check if a dependency is going to be unregistered | (dep, _):_ <- mapMaybe (`Map.lookup` toUnregister) deps @@ -342,7 +333,7 @@ -- step. addFinal :: LocalPackage -> Package -> Bool -> M () addFinal lp package isAllInOne = do - depsRes <- addPackageDeps package + depsRes <- addPackageDeps False package res <- case depsRes of Left e -> return $ Left e Right (missing, present, _minLoc) -> do @@ -361,12 +352,21 @@ Local package , taskPresent = present - , taskType = TTLocal lp + , taskType = TTFiles lp Local -- FIXME we can rely on this being Local, right? , taskAllInOne = isAllInOne , taskCachePkgSrc = CacheSrcLocal (toFilePath (lpDir lp)) + , taskAnyMissing = not $ Set.null missing + , taskBuildTypeConfig = packageBuildTypeConfig package } tell mempty { wFinals = Map.singleton (packageName package) res } +-- | Is this package being used as a library, or just as a build tool? +-- If the former, we need to ensure that a library actually +-- exists. See +-- +data DepType = AsLibrary | AsBuildTool + deriving (Show, Eq) + -- | Given a 'PackageName', adds all of the build tasks to build the -- package, if needed. -- @@ -402,32 +402,38 @@ -- 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 + -- FIXME Slightly hacky, no flags since + -- they likely won't affect executable + -- names. This code does not feel right. + tellExecutablesUpstream + (PackageIdentifierRevision (PackageIdentifier name (installedVersion installed)) CFILatest) + loc + Map.empty return $ Right $ ADRFound loc installed Just (PIOnlySource ps) -> do - tellExecutables name ps - installPackage name ps Nothing + tellExecutables ps + installPackage treatAsDep name ps Nothing Just (PIBoth ps installed) -> do - tellExecutables name ps - installPackage name ps (Just installed) + tellExecutables ps + installPackage treatAsDep name ps (Just installed) updateLibMap name res return res -tellExecutables :: PackageName -> PackageSource -> M () -tellExecutables _ (PSLocal lp) +-- FIXME what's the purpose of this? Add a Haddock! +tellExecutables :: PackageSource -> M () +tellExecutables (PSFiles lp _) | lpWanted lp = tellExecutablesPackage Local $ lpPackage lp | otherwise = return () -- Ignores ghcOptions because they don't matter for enumerating -- executables. -tellExecutables name (PSUpstream version loc flags _ghcOptions _gitSha) = - tellExecutablesUpstream name version loc flags +tellExecutables (PSIndex loc flags _ghcOptions pir) = + tellExecutablesUpstream pir loc flags -tellExecutablesUpstream :: PackageName -> Version -> InstallLocation -> Map FlagName Bool -> M () -tellExecutablesUpstream name version loc flags = do +tellExecutablesUpstream :: PackageIdentifierRevision -> InstallLocation -> Map FlagName Bool -> M () +tellExecutablesUpstream pir@(PackageIdentifierRevision (PackageIdentifier name _) _) loc flags = do ctx <- ask when (name `Set.member` extraToBuild ctx) $ do - p <- liftIO $ loadPackage ctx name version flags [] + p <- liftIO $ loadPackage ctx (PLIndex pir) flags [] tellExecutablesPackage loc p tellExecutablesPackage :: InstallLocation -> Package -> M () @@ -441,10 +447,10 @@ Just (PIOnlySource ps) -> goSource ps Just (PIBoth ps _) -> goSource ps - goSource (PSLocal lp) + goSource (PSFiles lp _) | lpWanted lp = exeComponents (lpComponents lp) | otherwise = Set.empty - goSource PSUpstream{} = Set.empty + goSource PSIndex{} = Set.empty tell mempty { wInstall = Map.fromList $ map (, loc) $ Set.toList $ filterComps myComps $ packageExes p } where @@ -454,30 +460,30 @@ -- | Given a 'PackageSource' and perhaps an 'Installed' value, adds -- build 'Task's for the package and its dependencies. -installPackage - :: PackageName - -> PackageSource - -> Maybe Installed - -> M (Either ConstructPlanException AddDepRes) -installPackage name ps minstalled = do +installPackage :: Bool -- ^ is this being used by a dependency? + -> PackageName + -> PackageSource + -> Maybe Installed + -> M (Either ConstructPlanException AddDepRes) +installPackage treatAsDep name ps minstalled = do ctx <- ask case ps of - PSUpstream version _ flags ghcOptions _ -> do + PSIndex _ flags ghcOptions pkgLoc -> do planDebug $ "installPackage: Doing all-in-one build for upstream package " ++ show name - package <- liftIO $ loadPackage ctx name version flags ghcOptions - resolveDepsAndInstall True ps package minstalled - PSLocal lp -> + package <- liftIO $ loadPackage ctx (PLIndex pkgLoc) flags ghcOptions -- FIXME be more efficient! Get this from the LoadedPackageInfo! + resolveDepsAndInstall True treatAsDep ps package minstalled + PSFiles lp _ -> case lpTestBench lp of Nothing -> do planDebug $ "installPackage: No test / bench component for " ++ show name ++ " so doing an all-in-one build." - resolveDepsAndInstall True ps (lpPackage lp) minstalled + resolveDepsAndInstall True treatAsDep ps (lpPackage lp) minstalled Just tb -> do -- Attempt to find a plan which performs an all-in-one -- build. Ignore the writer action + reset the state if -- it fails. s <- get res <- pass $ do - res <- addPackageDeps tb + res <- addPackageDeps treatAsDep tb let writerFunc w = case res of Left _ -> mempty _ -> w @@ -498,7 +504,7 @@ put s -- Otherwise, fall back on building the -- tests / benchmarks in a separate step. - res' <- resolveDepsAndInstall False ps (lpPackage lp) minstalled + res' <- resolveDepsAndInstall False treatAsDep ps (lpPackage lp) minstalled when (isRight res') $ do -- Insert it into the map so that it's -- available for addFinal. @@ -507,12 +513,13 @@ return res' resolveDepsAndInstall :: Bool + -> Bool -> PackageSource -> Package -> Maybe Installed -> M (Either ConstructPlanException AddDepRes) -resolveDepsAndInstall isAllInOne ps package minstalled = do - res <- addPackageDeps package +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 @@ -561,12 +568,18 @@ , taskPresent = present , taskType = case ps of - PSLocal lp -> TTLocal lp - PSUpstream _ loc _ _ sha -> TTUpstream package (loc <> minLoc) sha + PSFiles lp loc -> TTFiles lp (loc <> minLoc) + PSIndex loc _ _ pkgLoc -> TTIndex package (loc <> minLoc) pkgLoc , taskAllInOne = isAllInOne , taskCachePkgSrc = toCachePkgSrc ps + , taskAnyMissing = not $ Set.null missing + , taskBuildTypeConfig = packageBuildTypeConfig package } +-- | Is the build type of the package Configure +packageBuildTypeConfig :: Package -> Bool +packageBuildTypeConfig pkg = packageBuildType pkg == Just Configure + -- Update response in the lib map. If it is an error, and there's -- already an error about cyclic dependencies, prefer the cyclic error. updateLibMap :: PackageName -> Either ConstructPlanException AddDepRes -> M () @@ -590,12 +603,13 @@ -- then the parent package must be installed locally. Otherwise, if it -- is 'Snap', then it can either be installed locally or in the -- snapshot. -addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, InstallLocation)) -addPackageDeps package = do +addPackageDeps :: Bool -- ^ is this being used by a dependency? + -> Package -> M (Either ConstructPlanException (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, InstallLocation)) +addPackageDeps treatAsDep package = do ctx <- ask deps' <- packageDepsWithTools package - deps <- forM (Map.toList deps') $ \(depname, range) -> do - eres <- addDep True depname + deps <- forM (Map.toList deps') $ \(depname, (range, depType)) -> do + eres <- addDep treatAsDep depname let getLatestApplicable = do vs <- liftIO $ getVersions ctx depname return (latestApplicableVersion range vs) @@ -608,6 +622,8 @@ _ -> Couldn'tResolveItsDependencies (packageVersion package) mlatestApplicable <- getLatestApplicable return $ Left (depname, (range, mlatestApplicable, bd)) + Right adr | depType == AsLibrary && not (adrHasLibrary adr) -> + return $ Left (depname, (range, Nothing, HasNoLibrary)) Right adr -> do addParent depname range Nothing inRange <- if adrVersion adr `withinRange` range @@ -645,7 +661,7 @@ (Set.singleton $ taskProvides task, Map.empty, taskLocation task) ADRFound loc (Executable _) -> return $ Right (Set.empty, Map.empty, loc) - ADRFound loc (Library ident gid) -> return $ Right + ADRFound loc (Library ident gid _) -> return $ Right (Set.empty, Map.singleton ident gid, loc) else do mlatestApplicable <- getLatestApplicable @@ -669,6 +685,23 @@ where val = (First mversion, [(packageIdentifier package, range)]) + adrHasLibrary :: AddDepRes -> Bool + adrHasLibrary (ADRToInstall task) = taskHasLibrary task + adrHasLibrary (ADRFound _ Library{}) = True + adrHasLibrary (ADRFound _ Executable{}) = False + + taskHasLibrary :: Task -> Bool + taskHasLibrary task = + case taskType task of + TTFiles lp _ -> packageHasLibrary $ lpPackage lp + TTIndex p _ _ -> packageHasLibrary p + + packageHasLibrary :: Package -> Bool + packageHasLibrary p = + case packageLibraries p of + HasLibraries _ -> True + NoLibraries -> False + checkDirtiness :: PackageSource -> Installed -> Package @@ -677,7 +710,7 @@ -> M Bool checkDirtiness ps installed package present wanted = do ctx <- ask - moldOpts <- flip runLoggingT (logFunc ctx) $ tryGetFlagCache installed + moldOpts <- runRIO ctx $ tryGetFlagCache installed let configOpts = configureOpts (view envConfigL ctx) (baseConfigOpts ctx) @@ -691,8 +724,8 @@ , configCacheDeps = Set.fromList $ Map.elems present , configCacheComponents = case ps of - PSLocal lp -> Set.map renderComponent $ lpComponents lp - PSUpstream{} -> Set.empty + PSFiles lp _ -> Set.map renderComponent $ lpComponents lp + PSIndex{} -> Set.empty , configCacheHaddock = shouldHaddockPackage buildOpts wanted (packageName package) || -- Disabling haddocks when old config had haddocks doesn't make dirty. @@ -782,76 +815,74 @@ pkgSrcName CacheSrcUpstream = "upstream source" psForceDirty :: PackageSource -> Bool -psForceDirty (PSLocal lp) = lpForceDirty lp -psForceDirty PSUpstream{} = False +psForceDirty (PSFiles lp _) = lpForceDirty lp +psForceDirty PSIndex{} = False psDirty :: PackageSource -> Maybe (Set FilePath) -psDirty (PSLocal lp) = lpDirtyFiles lp -psDirty PSUpstream{} = Nothing -- files never change in an upstream package +psDirty (PSFiles lp _) = lpDirtyFiles lp +psDirty PSIndex{} = Nothing -- files never change in an upstream package psLocal :: PackageSource -> Bool -psLocal (PSLocal _) = True -psLocal PSUpstream{} = False +psLocal (PSFiles _ loc) = loc == Local -- FIXME this is probably not the right logic, see configureOptsNoDir. We probably want to check if this appears in packages: +psLocal PSIndex{} = False -- | Get all of the dependencies for a given package, including guessed build -- tool dependencies. -packageDepsWithTools :: Package -> M (Map PackageName VersionRange) +packageDepsWithTools :: Package -> M (Map PackageName (VersionRange, DepType)) packageDepsWithTools p = do ctx <- ask -- TODO: it would be cool to defer these warnings until there's an -- actual issue building the package. - let toEither (Cabal.Dependency (Cabal.PackageName name) _) mp = + let toEither name mp = case Map.toList mp of - [] -> Left (NoToolFound name (packageName p)) + [] -> Left (ToolWarning name (packageName p) Nothing) [_] -> Right mp - xs -> Left (AmbiguousToolsFound name (packageName p) (map fst xs)) + ((x, _):(y, _):zs) -> + Left (ToolWarning name (packageName p) (Just (x, y, map fst zs))) (warnings0, toolDeps) = partitionEithers $ - map (\dep -> toEither dep (toolToPackages ctx dep)) (packageTools p) + map (\dep -> toEither dep (toolToPackages ctx dep)) (Map.keys (packageTools p)) -- Check whether the tool is on the PATH before warning about it. - warnings <- fmap catMaybes $ forM warnings0 $ \warning -> do - let toolName = case warning of - NoToolFound tool _ -> tool - AmbiguousToolsFound tool _ _ -> tool + warnings <- fmap catMaybes $ forM warnings0 $ \warning@(ToolWarning (ExeName toolName) _ _) -> do config <- view configL menv <- liftIO $ configEnvOverride config minimalEnvSettings { esIncludeLocals = True } - mfound <- findExecutable menv toolName + mfound <- findExecutable menv $ T.unpack toolName case mfound of Nothing -> return (Just warning) Just _ -> return Nothing tell mempty { wWarnings = (map toolWarningText warnings ++) } - when (any isNoToolFound warnings) $ do - let msg = T.unlines - [ "Missing build-tools may be caused by dependencies of the build-tool being overridden by extra-deps." - , "This should be fixed soon - see this issue https://github.com/commercialhaskell/stack/issues/595" - ] - tell mempty { wWarnings = (msg:) } - return $ Map.unionsWith intersectVersionRanges - $ packageDeps p - : toolDeps - -data ToolWarning - = NoToolFound String PackageName - | AmbiguousToolsFound String PackageName [PackageName] + return $ Map.unionsWith + (\(vr1, dt1) (vr2, dt2) -> + ( intersectVersionRanges vr1 vr2 + , case dt1 of + AsLibrary -> AsLibrary + AsBuildTool -> dt2 + ) + ) + $ ((, AsLibrary) <$> packageDeps p) + : (Map.map (, AsBuildTool) <$> toolDeps) -isNoToolFound :: ToolWarning -> Bool -isNoToolFound NoToolFound{} = True -isNoToolFound _ = False +-- | Warn about tools in the snapshot definition. States the tool name +-- expected, the package name using it, and found packages. If the +-- last value is Nothing, it means the tool was not found +-- anywhere. For a Just value, it was found in at least two packages. +data ToolWarning = ToolWarning ExeName PackageName (Maybe (PackageName, PackageName, [PackageName])) + deriving Show toolWarningText :: ToolWarning -> Text -toolWarningText (NoToolFound toolName pkgName) = +toolWarningText (ToolWarning (ExeName toolName) pkgName Nothing) = "No packages found in snapshot which provide a " <> T.pack (show toolName) <> " executable, which is a build-tool dependency of " <> T.pack (show (packageNameString pkgName)) -toolWarningText (AmbiguousToolsFound toolName pkgName options) = +toolWarningText (ToolWarning (ExeName toolName) pkgName (Just (option1, option2, options))) = "Multiple packages found in snapshot which provide a " <> T.pack (show toolName) <> " exeuctable, which is a build-tool dependency of " <> T.pack (show (packageNameString pkgName)) <> ", so none will be installed.\n" <> "Here's the list of packages which provide it: " <> - T.intercalate ", " (map packageNameText options) <> + T.intercalate ", " (map packageNameText (option1:option2:options)) <> "\nSince there's no good way to choose, you may need to install it manually." -- | Strip out anything from the @Plan@ intended for the local database @@ -863,11 +894,7 @@ , planInstallExes = Map.filter (/= Local) $ planInstallExes plan } where - checkTask task = - case taskType task of - TTLocal _ -> False - TTUpstream _ Local _ -> False - TTUpstream _ Snap _ -> True + checkTask task = taskLocation task == Snap stripNonDeps :: Set PackageName -> Plan -> Plan stripNonDeps deps plan = plan @@ -884,12 +911,12 @@ -- | Is the given package/version combo defined in the snapshot? inSnapshot :: PackageName -> Version -> M Bool inSnapshot name version = do - p <- asks mbp + p <- asks ls ls <- asks localNames return $ fromMaybe False $ do guard $ not $ name `Set.member` ls - mpi <- Map.lookup name (mbpPackages p) - return $ mpiVersion mpi == version + lpi <- Map.lookup name (lsPackages p) + return $ lpiVersion lpi == version data ConstructPlanException = DependencyCycleDetected [PackageName] @@ -908,6 +935,8 @@ = NotInBuildPlan | Couldn'tResolveItsDependencies Version | DependencyMismatch Version + | HasNoLibrary + -- ^ See description of 'DepType' deriving (Typeable, Eq, Ord, Show) -- TODO: Consider intersecting version ranges for multiple deps on a @@ -920,17 +949,28 @@ -> Set PackageName -> AnsiDoc pprintExceptions exceptions stackYaml parentMap wanted = - "While constructing the build plan, the following exceptions were encountered:" <> line <> line <> - mconcat (intersperse (line <> line) (mapMaybe pprintException exceptions')) <> line <> - if Map.null extras then "" else - line <> - "Recommended action: try adding the following to your extra-deps in" <+> - toAnsiDoc (display stackYaml) <> ":" <> - line <> - vsep (map pprintExtra (Map.toList extras)) <> - line <> - line <> - "You may also want to try the 'stack solver' command" + mconcat $ + [ flow "While constructing the build plan, the following exceptions were encountered:" + , line <> line + , mconcat (intersperse (line <> line) (mapMaybe pprintException exceptions')) + , line <> line + , flow "Some potential ways to resolve this:" + , line <> line + ] ++ + (if Map.null extras then [] else + [ " *" <+> align + (flow "Recommended action: try adding the following to your extra-deps in" <+> + toAnsiDoc (display stackYaml) <> ":") + , line <> line + , vsep (map pprintExtra (Map.toList extras)) + , line <> line + ] + ) ++ + [ " *" <+> align (flow "Set 'allow-newer: true' to ignore all version constraints and build anyway.") + , line <> line + , " *" <+> align (flow "You may also want to try using the 'stack solver' command.") + , line + ] where exceptions' = nubOrd exceptions @@ -940,8 +980,11 @@ getExtras (DependencyPlanFailures _ m) = Map.unions $ map go $ Map.toList m where + -- TODO: Likely a good idea to distinguish these to the user. In particular, for DependencyMismatch go (name, (_range, Just version, NotInBuildPlan)) = Map.singleton name version + go (name, (_range, Just version, DependencyMismatch{})) = + Map.singleton name version go _ = Map.empty pprintExtra (name, version) = fromString (concat ["- ", packageNameString name, "-", versionString version]) @@ -952,32 +995,33 @@ toNotInBuildPlan _ = [] pprintException (DependencyCycleDetected pNames) = Just $ - "Dependency cycle detected in packages:" <> line <> - indent 4 (encloseSep "[" "]" "," (map (errorRed . fromString . packageNameString) pNames)) + flow "Dependency cycle detected in packages:" <> line <> + indent 4 (encloseSep "[" "]" "," (map (styleError . display) pNames)) pprintException (DependencyPlanFailures pkg pDeps) = case mapMaybe pprintDep (Map.toList pDeps) of [] -> Nothing depErrors -> Just $ - "In the dependencies for" <+> pkgIdent <> + flow "In the dependencies for" <+> pkgIdent <> pprintFlags (packageFlags pkg) <> ":" <> line <> indent 4 (vsep depErrors) <> case getShortestDepsPath parentMap wanted (packageName pkg) of - Nothing -> line <> "needed for unknown reason - stack invariant violated." - Just [] -> line <> "needed since" <+> pkgIdent <+> "is a build target." - Just (target:path) -> line <> "needed due to " <> encloseSep "" "" " -> " pathElems + Nothing -> line <> flow "needed for unknown reason - stack invariant violated." + Just [] -> line <> flow "needed since" <+> pkgName <+> flow "is a build target." + Just (target:path) -> line <> flow "needed due to" <+> encloseSep "" "" " -> " pathElems where pathElems = - [displayTargetPkgId target] ++ + [styleTarget . display $ target] ++ map display path ++ [pkgIdent] where - pkgIdent = displayCurrentPkgId (packageIdentifier pkg) + pkgName = styleCurrent . display $ packageName pkg + pkgIdent = styleCurrent . display $ packageIdentifier pkg -- Skip these when they are redundant with 'NotInBuildPlan' info. pprintException (UnknownPackage name) | name `Set.member` allNotInBuildPlan = Nothing | name `HashSet.member` wiredInPackages = - Just $ "Can't build a package with same name as a wired-in-package:" <+> displayCurrentPkgName name - | otherwise = Just $ "Unknown package:" <+> displayCurrentPkgName name + Just $ flow "Can't build a package with same name as a wired-in-package:" <+> (styleCurrent . display $ name) + | otherwise = Just $ flow "Unknown package:" <+> (styleCurrent . display $ name) pprintFlags flags | Map.null flags = "" @@ -987,29 +1031,32 @@ pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of NotInBuildPlan -> Just $ - errorRed (display name) <+> - align ("must match" <+> goodRange <> "," <> softline <> - "but the stack configuration has no specified version" <> + styleError (display name) <+> + align (flow "must match" <+> goodRange <> "," <> softline <> + flow "but the stack configuration has no specified version" <> latestApplicable Nothing) -- TODO: For local packages, suggest editing constraints DependencyMismatch version -> Just $ - displayErrorPkgId (PackageIdentifier name version) <+> - align ("must match" <+> goodRange <> + (styleError . display) (PackageIdentifier name version) <+> + align (flow "from stack configuration does not match" <+> goodRange <> latestApplicable (Just version)) -- I think the main useful info is these explain why missing -- packages are needed. Instead lets give the user the shortest -- path from a target to the package. Couldn'tResolveItsDependencies _version -> Nothing + HasNoLibrary -> Just $ + styleError (display name) <+> + align (flow "is a library dependency, but the package provides no library") where - goodRange = goodGreen (fromString (Cabal.display range)) + goodRange = styleGood (fromString (Cabal.display range)) latestApplicable mversion = case mlatestApplicable of Nothing -> "" Just la | mlatestApplicable == mversion -> softline <> - "(latest applicable is specified)" + flow "(latest matching version is specified)" | otherwise -> softline <> - "(latest applicable is " <> goodGreen (display la) <> ")" + flow "(latest matching version is" <+> styleGood (display la) <> ")" -- | Get the shortest reason for the package to be in the build plan. In -- other words, trace the parent dependencies back to a 'wanted' diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -8,6 +10,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} -- | Perform a build module Stack.Build.Execute ( printPlan @@ -20,51 +23,29 @@ , ExcludeTHLoading(..) ) where -import Control.Applicative -import Control.Arrow ((&&&), second) import Control.Concurrent.Execute -import Control.Concurrent.MVar.Lifted import Control.Concurrent.STM -import Control.Exception.Safe (catchIO) -import Control.Exception.Lifted -import Control.Monad (liftM, when, unless, void) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Trans.Control (liftBaseWith) -import Control.Monad.Trans.Resource +import Stack.Prelude import Crypto.Hash import Data.Attoparsec.Text hiding (try) import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString as S import qualified Data.ByteString.Base64.URL as B64URL import Data.Char (isSpace) -import Data.Conduit +import Data.Conduit hiding (runConduitRes) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import qualified Data.Conduit.Text as CT -import Data.Either (isRight) import Data.FileEmbed (embedFile, makeRelativeToProject) -import Data.Foldable (forM_, any) -import Data.Function -import Data.IORef import Data.IORef.RunOnce (runOnce) import Data.List hiding (any) -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 (forMaybeM) -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as Set import Data.Streaming.Process hiding (callProcess, env) -import Data.String -import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Text.Extra (stripCR) import Data.Time.Clock (getCurrentTime) -import Data.Traversable (forM) import Data.Tuple import qualified Distribution.PackageDescription as C import qualified Distribution.Simple.Build.Macros as C @@ -75,8 +56,7 @@ import Path import Path.CheckInstall import Path.Extra (toFilePathNoTrailingSep, rejectMissingFile) -import Path.IO hiding (findExecutable, makeAbsolute) -import Prelude hiding (FilePath, writeFile, any) +import Path.IO hiding (findExecutable, makeAbsolute, withSystemTempDir) import Stack.Build.Cache import Stack.Build.Haddock import Stack.Build.Installed @@ -84,6 +64,7 @@ import Stack.Build.Target import Stack.Config import Stack.Constants +import Stack.Constants.Config import Stack.Coverage import Stack.Fetch as Fetch import Stack.GhcPkg @@ -94,11 +75,10 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId -import Stack.Types.Internal import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT +import Stack.Types.Runner import Stack.Types.Version import qualified System.Directory as D import System.Environment (getExecutablePath) @@ -114,35 +94,37 @@ import System.Process.Internals (createProcess_) #endif +-- | Has an executable been built or not? +data ExecutableBuildStatus + = ExecutableBuilt + | ExecutableNotBuilt + deriving (Show, Eq, Ord) + -- | Fetch the packages necessary for a build, for example in combination with a dry run. -preFetch :: (StackM env m, HasEnvConfig env) => Plan -> m () +preFetch :: HasEnvConfig env => Plan -> RIO env () preFetch plan - | Set.null idents = $logDebug "Nothing to fetch" + | Set.null idents = logDebug "Nothing to fetch" | otherwise = do - $logDebug $ T.pack $ + logDebug $ T.pack $ "Prefetching: " ++ intercalate ", " (map packageIdentifierString $ Set.toList idents) fetchPackages idents where - idents = Set.unions $ map toIdent $ Map.toList $ planTasks plan + idents = Set.unions $ map toIdent $ Map.elems $ planTasks plan - toIdent (name, task) = + toIdent task = case taskType task of - TTLocal _ -> Set.empty - TTUpstream package _ _ -> Set.singleton $ PackageIdentifier - name - (packageVersion package) + TTFiles{} -> Set.empty + TTIndex _ _ (PackageIdentifierRevision ident _) -> Set.singleton ident -- | Print a description of build plan for human consumption. -printPlan :: (StackM env m) - => Plan - -> m () +printPlan :: HasRunner env => Plan -> RIO env () printPlan plan = do case Map.elems $ planUnregisterLocal plan of - [] -> $logInfo "No packages would be unregistered." + [] -> logInfo "No packages would be unregistered." xs -> do - $logInfo "Would unregister locally:" - forM_ xs $ \(ident, reason) -> $logInfo $ T.concat + logInfo "Would unregister locally:" + forM_ xs $ \(ident, reason) -> logInfo $ T.concat [ T.pack $ packageIdentifierString ident , if T.null reason then "" @@ -153,13 +135,13 @@ ] ] - $logInfo "" + logInfo "" case Map.elems $ planTasks plan of - [] -> $logInfo "Nothing to build." + [] -> logInfo "Nothing to build." xs -> do - $logInfo "Would build:" - mapM_ ($logInfo . displayTask) xs + logInfo "Would build:" + mapM_ (logInfo . displayTask) xs let hasTests = not . Set.null . testComponents . taskComponents hasBenches = not . Set.null . benchComponents . taskComponents @@ -167,21 +149,21 @@ benches = Map.elems $ Map.filter hasBenches $ planFinals plan unless (null tests) $ do - $logInfo "" - $logInfo "Would test:" - mapM_ ($logInfo . displayTask) tests + logInfo "" + logInfo "Would test:" + mapM_ (logInfo . displayTask) tests unless (null benches) $ do - $logInfo "" - $logInfo "Would benchmark:" - mapM_ ($logInfo . displayTask) benches + logInfo "" + logInfo "Would benchmark:" + mapM_ (logInfo . displayTask) benches - $logInfo "" + logInfo "" case Map.toList $ planInstallExes plan of - [] -> $logInfo "No executables to be installed." + [] -> logInfo "No executables to be installed." xs -> do - $logInfo "Would install executables:" - forM_ xs $ \(name, loc) -> $logInfo $ T.concat + logInfo "Would install executables:" + forM_ xs $ \(name, loc) -> logInfo $ T.concat [ name , " from " , case loc of @@ -200,8 +182,8 @@ Local -> "local" , ", source=" , case taskType task of - TTLocal lp -> toFilePath $ lpDir lp - TTUpstream{} -> "package index" + TTFiles lp _ -> toFilePath $ lpDir lp + TTIndex{} -> "package index" , if Set.null missing then "" else ", after: " ++ intercalate "," (map packageIdentifierString $ Set.toList missing) @@ -209,7 +191,7 @@ where missing = tcoMissing $ taskConfigOpts task -data ExecuteEnv m = ExecuteEnv +data ExecuteEnv = ExecuteEnv { eeEnvOverride :: !EnvOverride , eeConfigureLock :: !(MVar ()) , eeInstallLock :: !(MVar ()) @@ -233,8 +215,8 @@ , eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () () ()))) , eeLocalDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () () ()))) , eeLogFiles :: !(TChan (Path Abs Dir, Path Abs File)) - , eeGetGhcPath :: !(m (Path Abs File)) - , eeGetGhcjsPath :: !(m (Path Abs File)) + , eeGetGhcPath :: !(forall m. MonadIO m => m (Path Abs File)) + , eeGetGhcjsPath :: !(forall m. MonadIO m => m (Path Abs File)) , eeCustomBuilt :: !(IORef (Set PackageName)) -- ^ Stores which packages with custom-setup have already had their -- Setup.hs built. @@ -267,11 +249,11 @@ encodeUtf8 (T.pack (unwords buildSetupArgs)) <> setupGhciShimCode <> simpleSetupCode -- | Get a compiled Setup exe -getSetupExe :: (StackM env m, HasEnvConfig env) +getSetupExe :: HasEnvConfig env => Path Abs File -- ^ Setup.hs input file -> Path Abs File -- ^ SetupShim.hs input file -> Path Abs Dir -- ^ temporary directory - -> m (Maybe (Path Abs File)) + -> RIO env (Maybe (Path Abs File)) getSetupExe setupHs setupShimHs tmpdir = do wc <- view $ actualCompilerVersionL.whichCompilerL platformDir <- platformGhcRelDir @@ -324,13 +306,16 @@ , toFilePath tmpOutputPath ] ++ ["-build-runner" | wc == Ghcjs] - runCmd' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args) Nothing + callProcess' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args) + `catch` \(ProcessExitedUnsuccessfully _ ec) -> do + compilerPath <- getCompilerPath wc + throwM $ SetupHsBuildFailure ec Nothing compilerPath args Nothing [] when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath renameFile tmpExePath exePath return $ Just exePath -- | Execute a function that takes an 'ExecuteEnv'. -withExecuteEnv :: forall env m a. (StackM env m, HasEnvConfig env) +withExecuteEnv :: forall env a. HasEnvConfig env => EnvOverride -> BuildOpts -> BuildOptsCLI @@ -339,18 +324,18 @@ -> [DumpPackage () () ()] -- ^ global packages -> [DumpPackage () () ()] -- ^ snapshot packages -> [DumpPackage () () ()] -- ^ local packages - -> (ExecuteEnv m -> m a) - -> m a -withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner = do + -> (ExecuteEnv -> RIO env a) + -> RIO env a +withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner = withSystemTempDir stackProgName $ \tmpdir -> do - configLock <- newMVar () - installLock <- newMVar () + configLock <- liftIO $ newMVar () + installLock <- liftIO $ newMVar () idMap <- liftIO $ newTVarIO Map.empty config <- view configL getGhcPath <- runOnce $ getCompilerPath Ghc getGhcjsPath <- runOnce $ getCompilerPath Ghcjs - customBuiltRef <- liftIO $ newIORef Set.empty + customBuiltRef <- newIORef Set.empty -- Create files for simple setup and setup shim, if necessary let setupSrcDir = @@ -373,6 +358,7 @@ localPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages) logFilesTChan <- liftIO $ atomically newTChan let totalWanted = length $ filter lpWanted locals + env <- ask inner ExecuteEnv { eeEnvOverride = menv , eeBuildOpts = bopts @@ -398,14 +384,14 @@ , eeSnapshotDumpPkgs = snapshotPackagesTVar , eeLocalDumpPkgs = localPackagesTVar , eeLogFiles = logFilesTChan - , eeGetGhcPath = getGhcPath - , eeGetGhcjsPath = getGhcjsPath + , eeGetGhcPath = runRIO env getGhcPath + , eeGetGhcjsPath = runRIO env getGhcjsPath , eeCustomBuilt = customBuiltRef } `finally` dumpLogs logFilesTChan totalWanted where toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp)) - dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> m () + dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env () dumpLogs chan totalWanted = do allLogs <- fmap reverse $ liftIO $ atomically drainChan case allLogs of @@ -418,13 +404,18 @@ DumpWarningLogs -> mapM_ dumpLogIfWarning allLogs DumpNoLogs | totalWanted > 1 -> - $logInfo $ T.concat + logInfo $ T.concat [ "Build output has been captured to log files, use " , "--dump-logs to see it on the console" ] | otherwise -> return () - $logInfo $ T.pack $ "Log files have been written to: " + logInfo $ T.pack $ "Log files have been written to: " ++ toFilePath (parent (snd firstLog)) + + -- We only strip the colors /after/ we've dumped logs, so that + -- we get pretty colors in our dump output on the terminal. + colors <- shouldForceGhcColorFlag + when colors $ liftIO $ mapM_ (stripColors . snd) allLogs where drainChan :: STM [(Path Abs Dir, Path Abs File)] drainChan = do @@ -435,10 +426,10 @@ xs <- drainChan return $ x:xs - dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> m () + dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> RIO env () dumpLogIfWarning (pkgDir, filepath) = do firstWarning <- runResourceT - $ CB.sourceFile (toFilePath filepath) + $ transPipe liftResourceT (CB.sourceFile (toFilePath filepath)) $$ CT.decodeUtf8Lenient =$ CT.lines =$ CL.map stripCR @@ -450,19 +441,40 @@ isWarning t = ": Warning:" `T.isSuffixOf` t -- prior to GHC 8 || ": warning:" `T.isInfixOf` t -- GHC 8 is slightly different - dumpLog :: String -> (Path Abs Dir, Path Abs File) -> m () + dumpLog :: String -> (Path Abs Dir, Path Abs File) -> RIO env () dumpLog msgSuffix (pkgDir, filepath) = do - $logInfo $ T.pack $ concat ["\n-- Dumping log file", msgSuffix, ": ", toFilePath filepath, "\n"] + logInfo $ T.pack $ concat ["\n-- Dumping log file", msgSuffix, ": ", toFilePath filepath, "\n"] compilerVer <- view actualCompilerVersionL runResourceT - $ CB.sourceFile (toFilePath filepath) + $ transPipe liftResourceT (CB.sourceFile (toFilePath filepath)) $$ CT.decodeUtf8Lenient =$ mungeBuildOutput ExcludeTHLoading ConvertPathsToAbsolute pkgDir compilerVer - =$ CL.mapM_ $logInfo - $logInfo $ T.pack $ "\n-- End of log file: " ++ toFilePath filepath ++ "\n" + =$ CL.mapM_ logInfo + logInfo $ T.pack $ "\n-- End of log file: " ++ toFilePath filepath ++ "\n" + stripColors :: Path Abs File -> IO () + stripColors fp = do + let colorfp = toFilePath fp ++ "-color" + runConduitRes $ CB.sourceFile (toFilePath fp) .| CB.sinkFile colorfp + runConduitRes + $ CB.sourceFile colorfp + .| noColors + .| CB.sinkFile (toFilePath fp) + + where + noColors = do + CB.takeWhile (/= 27) -- ESC + mnext <- CB.head + case mnext of + Nothing -> return () + Just x -> assert (x == 27) $ do + -- Color sequences always end with an m + CB.dropWhile (/= 109) -- m + CB.drop 1 -- drop the m itself + noColors + -- | Perform the actual plan -executePlan :: (StackM env m, HasEnvConfig env) +executePlan :: HasEnvConfig env => EnvOverride -> BuildOptsCLI -> BaseConfigOpts @@ -471,11 +483,11 @@ -> [DumpPackage () () ()] -- ^ snapshot packages -> [DumpPackage () () ()] -- ^ local packages -> InstalledMap - -> Map PackageName SimpleTarget + -> Map PackageName Target -> Plan - -> m () + -> RIO env () executePlan menv boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do - $logDebug "Executing the build plan" + logDebug "Executing the build plan" bopts <- view buildOptsL withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap targets plan) @@ -487,20 +499,24 @@ , esIncludeGhcPackagePath = True , esStackExe = True , esLocaleUtf8 = False + , esKeepGhcRts = False } forM_ (boptsCLIExec boptsCli) $ \(cmd, args) -> - $withProcessTimeLog cmd args $ + withProcessTimeLog cmd args $ callProcess (Cmd Nothing cmd menv' args) copyExecutables - :: (StackM env m, HasEnvConfig env) + :: HasEnvConfig env => Map Text InstallLocation - -> m () + -> RIO env () copyExecutables exes | Map.null exes = return () copyExecutables exes = do snapBin <- ( bindirSuffix) `liftM` installationRootDeps localBin <- ( bindirSuffix) `liftM` installationRootLocal - destDir <- view $ configL.to configLocalBin + compilerSpecific <- boptsInstallCompilerTool <$> view buildOptsL + destDir <- if compilerSpecific + then bindirCompilerTools + else view $ configL.to configLocalBin ensureDir destDir destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir @@ -518,11 +534,11 @@ case loc of Snap -> snapBin Local -> localBin - mfp <- forgivingAbsence (resolveFile bindir $ T.unpack name ++ ext) + mfp <- liftIO $ forgivingAbsence (resolveFile bindir $ T.unpack name ++ ext) >>= rejectMissingFile case mfp of Nothing -> do - $logWarn $ T.concat + logWarn $ T.concat [ "Couldn't find executable " , name , " in directory " @@ -531,7 +547,7 @@ return Nothing Just file -> do let destFile = destDir' FP. T.unpack name ++ ext - $logInfo $ T.concat + logInfo $ T.concat [ "Copying from " , T.pack $ toFilePath file , " to " @@ -545,13 +561,13 @@ return $ Just (name <> T.pack ext) unless (null installed) $ do - $logInfo "" - $logInfo $ T.concat + logInfo "" + logInfo $ T.concat [ "Copied executables to " , T.pack destDir' , ":"] - forM_ installed $ \exe -> $logInfo ("- " <> exe) - warnInstallSearchPathIssues destDir' installed + forM_ installed $ \exe -> logInfo ("- " <> exe) + unless compilerSpecific $ warnInstallSearchPathIssues destDir' installed -- | Windows can't write over the current executable. Instead, we rename the @@ -566,12 +582,12 @@ old = dest ++ ".old" -- | Perform the actual plan (internal) -executePlan' :: (StackM env m, HasEnvConfig env) +executePlan' :: HasEnvConfig env => InstalledMap - -> Map PackageName SimpleTarget + -> Map PackageName Target -> Plan - -> ExecuteEnv m - -> m () + -> ExecuteEnv + -> RIO env () executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do when (toCoverage $ boptsTestOpts eeBuildOpts) deleteHpcReports cv <- view actualCompilerVersionL @@ -581,7 +597,7 @@ ids -> do localDB <- packageDatabaseLocal forM_ ids $ \(id', (ident, reason)) -> do - $logInfo $ T.concat + logInfo $ T.concat [ T.pack $ packageIdentifierString ident , ": unregistering" , if T.null reason @@ -597,13 +613,9 @@ liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap -> foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan) - -- Yes, we're explicitly discarding result values, which in general would - -- be bad. monad-unlift does this all properly at the type system level, - -- but I don't want to pull it in for this one use case, when we know that - -- stack always using transformer stacks that are safe for this use case. - runInBase <- liftBaseWith $ \run -> return (void . run) + run <- askRunInIO - let actions = concatMap (toActions installedMap' runInBase ee) $ Map.elems $ Map.mergeWithKey + let actions = concatMap (toActions installedMap' run ee) $ Map.elems $ Map.mergeWithKey (\_ b f -> Just (Just b, Just f)) (fmap (\b -> (Just b, Nothing))) (fmap (\f -> (Nothing, Just f))) @@ -625,10 +637,10 @@ let total = length actions loop prev | prev == total = - runInBase $ $logStickyDone ("Completed " <> T.pack (show total) <> " action(s).") + run $ logStickyDone ("Completed " <> T.pack (show total) <> " action(s).") | otherwise = do - when terminal $ runInBase $ - $logSticky ("Progress: " <> T.pack (show prev) <> "/" <> T.pack (show total)) + when terminal $ run $ + logSticky ("Progress: " <> T.pack (show prev) <> "/" <> T.pack (show total)) done <- atomically $ do done <- readTVar doneVar check $ done /= prev @@ -662,10 +674,10 @@ $ Map.elems $ planUnregisterLocal plan -toActions :: (StackM env m, HasEnvConfig env) +toActions :: HasEnvConfig env => InstalledMap - -> (m () -> IO ()) - -> ExecuteEnv m + -> (RIO env () -> IO ()) + -> ExecuteEnv -> (Maybe Task, Maybe Task) -- build and final -> [Action] toActions installedMap runInBase ee (mbuild, mfinal) = @@ -719,9 +731,9 @@ beopts = boptsBenchmarkOpts bopts -- | Generate the ConfigCache -getConfigCache :: (StackM env m, HasEnvConfig env) - => ExecuteEnv m -> Task -> InstalledMap -> Bool -> Bool - -> m (Map PackageIdentifier GhcPkgId, ConfigCache) +getConfigCache :: HasEnvConfig env + => ExecuteEnv -> Task -> InstalledMap -> Bool -> Bool + -> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache) getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBench = do useExactConf <- view $ configL.to configAllowNewer let extra = @@ -731,7 +743,7 @@ -- 'stack test'. See: -- https://github.com/commercialhaskell/stack/issues/805 case taskType of - TTLocal lp -> + TTFiles lp _ -> -- FIXME: make this work with exact-configuration. -- Not sure how to plumb the info atm. See -- https://github.com/commercialhaskell/stack/issues/2049 @@ -749,7 +761,7 @@ -> installedToGhcPkgId ident installed Just installed -> installedToGhcPkgId ident installed _ -> error "singleBuild: invariant violated, missing package ID missing" - installedToGhcPkgId ident (Library ident' x) = assert (ident == ident') $ Just (ident, x) + installedToGhcPkgId ident (Library ident' x _) = assert (ident == ident') $ Just (ident, x) installedToGhcPkgId _ (Executable _) = Nothing missing' = Map.fromList $ mapMaybe getMissing $ Set.toList missing TaskConfigOpts missing mkOpts = taskConfigOpts @@ -762,8 +774,8 @@ , configCacheDeps = allDeps , configCacheComponents = case taskType of - TTLocal lp -> Set.map renderComponent $ lpComponents lp - TTUpstream{} -> Set.empty + TTFiles lp _ -> Set.map renderComponent $ lpComponents lp + TTIndex{} -> Set.empty , configCacheHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides) , configCachePkgSrc = taskCachePkgSrc @@ -772,18 +784,19 @@ return (allDepsMap, cache) -- | Ensure that the configuration for the package matches what is given -ensureConfig :: (StackM env m, HasEnvConfig env) +ensureConfig :: HasEnvConfig env => ConfigCache -- ^ newConfigCache -> Path Abs Dir -- ^ package directory - -> ExecuteEnv m - -> m () -- ^ announce - -> (ExcludeTHLoading -> [String] -> m ()) -- ^ cabal + -> ExecuteEnv + -> RIO env () -- ^ announce + -> (ExcludeTHLoading -> [String] -> RIO env ()) -- ^ cabal -> Path Abs File -- ^ .cabal file - -> m Bool -ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do + -> Task + -> RIO env Bool +ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task = do newCabalMod <- liftIO (fmap modTime (D.getModificationTime (toFilePath cabalfp))) needConfig <- - if boptsReconfigure eeBuildOpts + if boptsReconfigure eeBuildOpts || taskAnyMissing task then return True else do -- We can ignore the components portion of the config @@ -801,6 +814,9 @@ return $ fmap ignoreComponents mOldConfigCache /= Just (ignoreComponents newConfigCache) || mOldCabalMod /= Just newCabalMod let ConfigureOpts dirs nodirs = configCacheOpts newConfigCache + + when (taskBuildTypeConfig task) ensureConfigureScript + when needConfig $ withMVar eeConfigureLock $ \_ -> do deleteCaches pkgDir announce @@ -825,9 +841,22 @@ writeCabalMod pkgDir newCabalMod return needConfig + where + -- When build-type is Configure, we need to have a configure + -- script in the local directory. If it doesn't exist, build it + -- with autoreconf -i. See: + -- https://github.com/commercialhaskell/stack/issues/3534 + ensureConfigureScript = do + let fp = pkgDir $(mkRelFile "configure") + exists <- doesFileExist fp + unless exists $ do + logInfo $ "Trying to generate configure with autoreconf in " <> T.pack (toFilePath pkgDir) + menv <- getMinimalEnvOverride + readProcessNull (Just pkgDir) menv "autoreconf" ["-i"] `catchAny` \ex -> + logWarn $ "Unable to run autoreconf: " <> T.pack (show ex) announceTask :: MonadLogger m => Task -> Text -> m () -announceTask task x = $logInfo $ T.concat +announceTask task x = logInfo $ T.concat [ T.pack $ packageIdentifierString $ taskProvides task , ": " , x @@ -844,10 +873,10 @@ -- custom setup is built. -- -- * Provides the user a function with which run the Cabal process. -withSingleContext :: forall env m a. (StackM env m, HasEnvConfig env) - => (m () -> IO ()) +withSingleContext :: forall env a. HasEnvConfig env + => (RIO env () -> IO ()) -> ActionContext - -> ExecuteEnv m + -> ExecuteEnv -> Task -> Maybe (Map PackageIdentifier GhcPkgId) -- ^ All dependencies' package ids to provide to Setup.hs. If @@ -857,12 +886,13 @@ -> ( Package -- Package info -> Path Abs File -- Cabal file path -> Path Abs Dir -- Package root directory file path - -> (ExcludeTHLoading -> [String] -> m ()) -- Function to run Cabal with args - -> (Text -> m ()) -- An 'announce' function, for different build phases + -> (ExcludeTHLoading -> [String] -> RIO env ()) + -- Function to run Cabal with args + -> (Text -> RIO env ()) -- An 'announce' function, for different build phases -> Bool -- Whether output should be directed to the console -> Maybe (Path Abs File, Handle) -- Log file - -> m a) - -> m a + -> RIO env a) + -> RIO env a withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 = withPackage $ \package cabalfp pkgDir -> withLogFile pkgDir package $ \mlogFile -> @@ -873,8 +903,8 @@ wanted = case taskType of - TTLocal lp -> lpWanted lp - TTUpstream{} -> False + TTFiles lp _ -> lpWanted lp + TTIndex{} -> False console = wanted && all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining) @@ -882,20 +912,16 @@ withPackage inner = case taskType of - TTLocal lp -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp) - TTUpstream package _ gitSHA1 -> do - mdist <- liftM Just distRelativeDir - m <- unpackPackageIdents eeTempDir mdist - $ Map.singleton taskProvides gitSHA1 - case Map.toList m of - [(ident, dir)] - | ident == taskProvides -> do - let name = packageIdentifierName taskProvides - cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal" - let cabalfp = dir cabalfpRel - inner package cabalfp dir - _ -> error $ "withPackage: invariant violated: " ++ show m + TTFiles lp _ -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp) + TTIndex package _ pir -> do + mdist <- distRelativeDir + dir <- unpackPackageIdent eeTempDir mdist pir + let name = packageIdentifierName taskProvides + cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal" + let cabalfp = dir cabalfpRel + inner package cabalfp dir + withLogFile pkgDir package inner | console = inner Nothing | otherwise = do @@ -905,7 +931,7 @@ -- We only want to dump logs for local non-dependency packages case taskType of - TTLocal lp | lpWanted lp -> + TTFiles lp _ | lpWanted lp -> liftIO $ atomically $ writeTChan eeLogFiles (pkgDir, logPath) _ -> return () @@ -918,8 +944,8 @@ :: Package -> Path Abs Dir -> Maybe (Path Abs File, Handle) - -> ((ExcludeTHLoading -> [String] -> m ()) -> m a) - -> m a + -> ((ExcludeTHLoading -> [String] -> RIO env ()) -> RIO env a) + -> RIO env a withCabal package pkgDir mlogFile inner = do config <- view configL @@ -931,6 +957,7 @@ , esIncludeGhcPackagePath = False , esStackExe = False , esLocaleUtf8 = True + , esKeepGhcRts = False } menv <- liftIO $ configEnvOverride config envSettings distRelativeDir' <- distRelativeDir @@ -961,20 +988,18 @@ : ["-hide-all-packages"] ) - warnCustomNoDeps :: m () + warnCustomNoDeps :: RIO env () warnCustomNoDeps = case (taskType, packageBuildType package) of - (TTLocal{}, Just C.Custom) -> do - $logWarn $ T.pack $ concat - [ "Package " - , packageNameString $ packageName package - , " uses a custom Cabal build, but does not use a custom-setup stanza" + (TTFiles lp Local, Just C.Custom) | lpWanted lp -> do + prettyWarnL + [ flow "Package" + , display $ packageName package + , flow "uses a custom Cabal build, but does not use a custom-setup stanza" ] - $logWarn "Using the explicit setup deps approach based on configuration" - $logWarn "Strongly recommend fixing the package's cabal file" _ -> return () - getPackageArgs :: Path Abs Dir -> m [String] + getPackageArgs :: Path Abs Dir -> RIO env [String] getPackageArgs setupDir = case (packageSetupDeps package, mdeps) of -- The package is using the Cabal custom-setup @@ -983,11 +1008,16 @@ -- explicit list of dependencies, and we -- should simply use all of them. (Just customSetupDeps, _) -> do + unless (Map.member $(mkPackageName "Cabal") customSetupDeps) $ + prettyWarnL + [ display $ packageName package + , "has a setup-depends field, but it does not mention a Cabal dependency. This is likely to cause build errors." + ] allDeps <- case mdeps of Just x -> return x Nothing -> do - $logWarn "In getPackageArgs: custom-setup in use, but no dependency map present" + prettyWarnS "In getPackageArgs: custom-setup in use, but no dependency map present" return Map.empty matchedDeps <- forM (Map.toList customSetupDeps) $ \(name, range) -> do let matches (PackageIdentifier name' version) = @@ -996,10 +1026,10 @@ case filter (matches . fst) (Map.toList allDeps) of x:xs -> do unless (null xs) - ($logWarn (T.pack ("Found multiple installed packages for custom-setup dep: " ++ packageNameString name))) + (logWarn (T.pack ("Found multiple installed packages for custom-setup dep: " ++ packageNameString name))) return ("-package-id=" ++ ghcPkgIdString (snd x), Just (toCabalPackageIdentifier (fst x))) [] -> do - $logWarn (T.pack ("Could not find custom-setup dep: " ++ packageNameString name)) + logWarn (T.pack ("Could not find custom-setup dep: " ++ packageNameString name)) return ("-package=" ++ packageNameString name, Nothing) let depsArgs = map fst matchedDeps -- Generate setup_macros.h and provide it to ghc @@ -1055,7 +1085,7 @@ setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args - runExe :: Path Abs File -> [String] -> m () + runExe :: Path Abs File -> [String] -> RIO env () runExe exeName fullArgs = do compilerVer <- view actualCompilerVersionL runAndOutput compilerVer `catch` \(ProcessExitedUnsuccessfully _ ec) -> do @@ -1065,19 +1095,19 @@ Just (logFile, h) -> do liftIO $ hClose h runResourceT - $ CB.sourceFile (toFilePath logFile) + $ transPipe liftResourceT (CB.sourceFile (toFilePath logFile)) =$= CT.decodeUtf8Lenient $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer =$ CL.consume - throwM $ CabalExitedUnsuccessfully + throwM $ SetupHsBuildFailure ec - taskProvides + (Just taskProvides) exeName fullArgs (fmap fst mlogFile) bss where - runAndOutput :: CompilerVersion -> m () + runAndOutput :: CompilerVersion 'CVActual -> RIO env () runAndOutput compilerVer = case mlogFile of Just (_, h) -> sinkProcessStderrStdoutHandle (Just pkgDir) menv (toFilePath exeName) fullArgs h h @@ -1088,7 +1118,7 @@ outputSink :: ExcludeTHLoading -> LogLevel - -> CompilerVersion + -> CompilerVersion 'CVActual -> Sink S.ByteString IO () outputSink excludeTH level compilerVer = CT.decodeUtf8Lenient @@ -1100,10 +1130,9 @@ ExcludeTHLoading -> ConvertPathsToAbsolute KeepTHLoading -> KeepPathsAsIs - wc <- view $ actualCompilerVersionL.whichCompilerL - exeName <- case (esetupexehs, wc) of - (Left setupExe, _) -> return setupExe - (Right setuphs, compiler) -> do + exeName <- case esetupexehs of + Left setupExe -> return setupExe + Right setuphs -> do distDir <- distDirFromDir pkgDir let setupDir = distDir $(mkRelDir "setup") outputFile = setupDir $(mkRelFile "setup") @@ -1112,6 +1141,7 @@ then return outputFile else do ensureDir setupDir + compiler <- view $ actualCompilerVersionL.whichCompilerL compilerPath <- case compiler of Ghc -> eeGetGhcPath @@ -1154,14 +1184,14 @@ -- local install directory. Note that this is literally invoking Cabal -- with @copy@, and not the copying done by @stack install@ - that is -- handled by 'copyExecutables'. -singleBuild :: forall env m. (StackM env m, HasEnvConfig env) - => (m () -> IO ()) +singleBuild :: forall env. (HasEnvConfig env, HasRunner env) + => (RIO env () -> IO ()) -> ActionContext - -> ExecuteEnv m + -> ExecuteEnv -> Task -> InstalledMap -> Bool -- ^ Is this a final build? - -> m () + -> RIO env () singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap isFinalBuild = do (allDepsMap, cache) <- getConfigCache ee task installedMap enableTests enableBenchmarks mprecompiled <- getPrecompiled cache @@ -1187,7 +1217,7 @@ enableTests = buildingFinals && any isCTest (taskComponents task) enableBenchmarks = buildingFinals && any isCBench (taskComponents task) - annSuffix = if result == "" then "" else " (" <> result <> ")" + annSuffix executableBuildStatuses = if result == "" then "" else " (" <> result <> ")" where result = T.intercalate " + " $ concat [ ["lib" | taskAllInOne && hasLib] @@ -1196,23 +1226,32 @@ , ["bench" | enableBenchmarks] ] (hasLib, hasExe) = case taskType of - TTLocal lp -> (packageHasLibrary (lpPackage lp), not (Set.null (exesToBuild lp))) + TTFiles lp Local -> + let hasLibrary = + case packageLibraries (lpPackage lp) of + NoLibraries -> False + HasLibraries _ -> True + in (hasLibrary, not (Set.null (exesToBuild executableBuildStatuses lp))) -- This isn't true, but we don't want to have this info for -- upstream deps. - TTUpstream{} -> (False, False) + _ -> (False, False) getPrecompiled cache = case taskLocation task of Snap | not shouldHaddockPackage' -> do - mpc <- readPrecompiledCache taskProvides - (configCacheOpts cache) - (configCacheDeps cache) + mpc <- + case taskLocation task of + Snap -> readPrecompiledCache + (ttPackageLocation taskType) + (configCacheOpts cache) + (configCacheDeps cache) + _ -> return Nothing case mpc of Nothing -> return Nothing -- Only pay attention to precompiled caches that refer to packages within -- the snapshot. Just pc | maybe False - (bcoSnapInstallRoot eeBaseConfigOpts `isParentOf`) + (bcoSnapInstallRoot eeBaseConfigOpts `isProperPrefixOf`) (parseAbsFile =<< pcLibrary pc) -> return Nothing -- If old precompiled cache files are left around but snapshots are deleted, @@ -1241,7 +1280,7 @@ menv' <- modifyEnvOverride menv $ Map.insert - "GHC_PACKAGE_PATH" + (ghcPkgPathEnvVar wc) (T.pack $ toFilePathNoTrailingSep $ bcoSnapDB eeBaseConfigOpts) -- In case a build of the library with different flags already exists, unregister it @@ -1281,18 +1320,24 @@ return $ Just $ case mpkgid of Nothing -> assert False $ Executable taskProvides - Just pkgid -> Library taskProvides pkgid + Just pkgid -> Library taskProvides pkgid Nothing where bindir = toFilePath $ bcoSnapInstallRoot eeBaseConfigOpts bindirSuffix 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" <> annSuffix)) cabal cabalfp + executableBuildStatuses <- getExecutableBuildStatuses package pkgDir + when (not (cabalIsSatisfied executableBuildStatuses) && taskIsTarget task) + (logInfo + ("Building all executables for `" <> packageNameText (packageName package) <> + "' once. After a successful build of all of them, only specified executables will be rebuilt.")) + _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix executableBuildStatuses)) cabal cabalfp task + let installedMapHasThisPkg :: Bool installedMapHasThisPkg = case Map.lookup (packageName package) installedMap of - Just (_, Library ident _) -> ident == taskProvides + Just (_, Library ident _ _) -> ident == taskProvides Just (_, Executable _) -> True _ -> False @@ -1304,38 +1349,40 @@ -- https://github.com/commercialhaskell/stack/issues/2787 (True, _) | null acDownstream -> return Nothing (_, True) | null acDownstream || installedMapHasThisPkg -> do - initialBuildSteps cabal announce + initialBuildSteps executableBuildStatuses cabal announce return Nothing - _ -> liftM Just $ realBuild cache package pkgDir cabal announce + _ -> liftM Just $ realBuild cache package pkgDir cabal announce executableBuildStatuses - initialBuildSteps cabal announce = do - () <- announce ("initial-build-steps" <> annSuffix) + initialBuildSteps executableBuildStatuses cabal announce = do + () <- announce ("initial-build-steps" <> annSuffix executableBuildStatuses) cabal KeepTHLoading ["repl", "stack-initial-build-steps"] realBuild :: ConfigCache -> Package -> Path Abs Dir - -> (ExcludeTHLoading -> [String] -> m ()) - -> (Text -> m ()) - -> m Installed - realBuild cache package pkgDir cabal announce = do + -> (ExcludeTHLoading -> [String] -> RIO env ()) + -> (Text -> RIO env ()) + -> Map Text ExecutableBuildStatus + -> RIO env Installed + realBuild cache package pkgDir cabal announce executableBuildStatuses = do wc <- view $ actualCompilerVersionL.whichCompilerL markExeNotInstalled (taskLocation task) taskProvides case taskType of - TTLocal lp -> do + TTFiles lp _ -> do -- FIXME should this only be for local packages? when enableTests $ unsetTestSuccess pkgDir writeBuildCache pkgDir $ lpNewBuildCache lp - TTUpstream{} -> return () + TTIndex{} -> return () -- FIXME: only output these if they're in the build plan. preBuildTime <- modTime <$> liftIO getCurrentTime let postBuildCheck _succeeded = do mlocalWarnings <- case taskType of - TTLocal lp -> do + TTFiles lp Local -> do warnings <- checkForUnlistedFiles taskType preBuildTime pkgDir + -- TODO: Perhaps only emit these warnings for non extra-dep? return (Just (lpCabalFile lp, warnings)) _ -> return Nothing -- NOTE: once @@ -1346,16 +1393,16 @@ "- In" <+> maybe "the library component" (\c -> fromString c <+> "component") mcomp <> ":" <> line <> - indent 4 (mconcat $ intersperse line $ map (goodGreen . fromString . C.display) modules) + indent 4 (mconcat $ intersperse line $ map (styleGood . fromString . C.display) modules) forM_ mlocalWarnings $ \(cabalfp, warnings) -> do - unless (null warnings) $ $prettyWarn $ + unless (null warnings) $ prettyWarn $ "The following modules should be added to exposed-modules or other-modules in" <+> display cabalfp <> ":" <> line <> indent 4 (mconcat $ map showModuleWarning warnings) <> line <> line <> "Missing modules in the cabal file are likely to cause undefined reference errors from the linker, along with other problems." - () <- announce ("build" <> annSuffix) + () <- announce ("build" <> annSuffix executableBuildStatuses) config <- view configL extraOpts <- extraBuildOptions wc eeBuildOpts let stripTHLoading @@ -1364,10 +1411,10 @@ cabal stripTHLoading (("build" :) $ (++ extraOpts) $ case (taskType, taskAllInOne, isFinalBuild) of (_, True, True) -> error "Invariant violated: cannot have an all-in-one build that also has a final build step." - (TTLocal lp, False, False) -> primaryComponentOptions lp - (TTLocal lp, False, True) -> finalComponentOptions lp - (TTLocal lp, True, False) -> primaryComponentOptions lp ++ finalComponentOptions lp - (TTUpstream{}, _, _) -> []) + (TTFiles lp _, False, False) -> primaryComponentOptions executableBuildStatuses lp + (TTFiles lp _, False, True) -> finalComponentOptions lp + (TTFiles lp _, True, False) -> primaryComponentOptions executableBuildStatuses lp ++ finalComponentOptions lp + (TTIndex{}, _, _) -> []) `catch` \ex -> case ex of CabalExitedUnsuccessfully{} -> postBuildCheck False >> throwM ex _ -> throwM ex @@ -1385,19 +1432,23 @@ -- Older hscolour colouring Left _ -> do hscolourExists <- doesExecutableExist eeEnvOverride "HsColour" - unless hscolourExists $ $logWarn + unless hscolourExists $ logWarn ("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <> "found on PATH (use 'stack install hscolour' to install).") return ["--hyperlink-source" | hscolourExists] cabal KeepTHLoading $ concat - [ ["haddock", "--html", "--html-location=../$pkg-$version/"] + [ ["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"] , sourceFlag , ["--internal" | boptsHaddockInternal eeBuildOpts] , [ "--haddock-option=" <> opt | opt <- hoAdditionalArgs (boptsHaddockOpts eeBuildOpts) ] ] - let shouldCopy = not isFinalBuild && (packageHasLibrary package || not (Set.null (packageExes package))) + let hasLibrary = + case packageLibraries package of + NoLibraries -> False + HasLibraries _ -> True + shouldCopy = not isFinalBuild && (hasLibrary || not (Set.null (packageExes package))) when shouldCopy $ withMVar eeInstallLock $ \() -> do announce "copy/register" eres <- try $ cabal KeepTHLoading ["copy"] @@ -1405,7 +1456,7 @@ Left err@CabalExitedUnsuccessfully{} -> throwM $ CabalCopyFailed (packageBuildType package == Just C.Simple) (show err) _ -> return () - when (packageHasLibrary package) $ cabal KeepTHLoading ["register"] + when hasLibrary $ cabal KeepTHLoading ["register"] let (installedPkgDb, installedDumpPkgsTVar) = case taskLocation task of @@ -1416,28 +1467,31 @@ ( bcoLocalDB eeBaseConfigOpts , eeLocalDumpPkgs ) let ident = PackageIdentifier (packageName package) (packageVersion package) - mpkgid <- if packageHasLibrary package - then do + mpkgid <- case packageLibraries package of + HasLibraries _ -> do mpkgid <- loadInstalledPkg eeEnvOverride wc [installedPkgDb] installedDumpPkgsTVar (packageName package) case mpkgid of Nothing -> throwM $ Couldn'tFindPkgId $ packageName package - Just pkgid -> return $ Library ident pkgid - else do + Just pkgid -> return $ Library ident pkgid Nothing + NoLibraries -> do markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow with writeFlagCache? return $ Executable ident case taskLocation task of - Snap -> writePrecompiledCache eeBaseConfigOpts taskProvides + Snap -> + writePrecompiledCache + eeBaseConfigOpts + (ttPackageLocation taskType) (configCacheOpts cache) (configCacheDeps cache) mpkgid (packageExes package) - Local -> return () + _ -> return () case taskType of - -- For upstream packages, pkgDir is in the tmp directory. We - -- eagerly delete it if no other tasks require it, to reduce - -- space usage in tmp (#3018). - TTUpstream{} -> do + -- For packages from a package index, pkgDir is in the tmp + -- directory. We eagerly delete it if no other tasks + -- require it, to reduce space usage in tmp (#3018). + TTIndex{} -> do let remaining = filter (\(ActionId x _) -> x == taskProvides) (Set.toList acRemaining) when (null remaining) $ removeDirRecur pkgDir _ -> return () @@ -1453,20 +1507,71 @@ return $ Just (dpGhcPkgId dp) _ -> error "singleBuild: invariant violated: multiple results when describing installed package" +-- | Get the build status of all the package executables. Do so by +-- testing whether their expected output file exists, e.g. +-- +-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha +-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha.exe +-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha.jsexe/ (NOTE: a dir) +getExecutableBuildStatuses + :: HasEnvConfig env + => Package -> Path Abs Dir -> RIO env (Map Text ExecutableBuildStatus) +getExecutableBuildStatuses package pkgDir = do + compiler <- view $ actualCompilerVersionL.whichCompilerL + distDir <- distDirFromDir pkgDir + platform <- view platformL + fmap + M.fromList + (mapM (checkExeStatus compiler platform distDir) (Set.toList (packageExes package))) + +-- | Check whether the given executable is defined in the given dist directory. +checkExeStatus + :: (MonadLogger m, MonadIO m, MonadThrow m) + => WhichCompiler + -> Platform + -> Path b Dir + -> Text + -> m (Text, ExecutableBuildStatus) +checkExeStatus compiler platform distDir name = do + exename <- parseRelDir (T.unpack name) + exists <- checkPath (distDir $(mkRelDir "build") exename) + pure + ( name + , if exists + then ExecutableBuilt + else ExecutableNotBuilt) + where + checkPath base = + case compiler of + Ghcjs -> do + dir <- parseRelDir (file ++ ".jsexe") + doesDirExist (base dir) + _ -> + case platform of + Platform _ Windows -> do + fileandext <- parseRelFile (file ++ ".exe") + doesFileExist (base fileandext) + _ -> do + fileandext <- parseRelFile file + doesFileExist (base fileandext) + where + file = T.unpack name + -- | Check if any unlisted files have been found, and add them to the build cache. -checkForUnlistedFiles :: (StackM env m, HasEnvConfig env) => TaskType -> ModTime -> Path Abs Dir -> m [PackageWarning] -checkForUnlistedFiles (TTLocal lp) preBuildTime pkgDir = do +checkForUnlistedFiles :: HasEnvConfig env => TaskType -> ModTime -> Path Abs Dir -> RIO env [PackageWarning] +checkForUnlistedFiles (TTFiles lp _) preBuildTime pkgDir = do (addBuildCache,warnings) <- addUnlistedToBuildCache preBuildTime (lpPackage lp) (lpCabalFile lp) + (lpComponents lp) (lpNewBuildCache lp) unless (null addBuildCache) $ writeBuildCache pkgDir $ Map.unions (lpNewBuildCache lp : addBuildCache) return warnings -checkForUnlistedFiles TTUpstream{} _ _ = return [] +checkForUnlistedFiles TTIndex{} _ _ = return [] -- | Determine if all of the dependencies given are installed depsPresent :: InstalledMap -> Map PackageName VersionRange -> Bool @@ -1479,15 +1584,15 @@ -- | Implements running a package's tests. Also handles producing -- coverage reports if coverage is enabled. -singleTest :: (StackM env m, HasEnvConfig env) - => (m () -> IO ()) +singleTest :: HasEnvConfig env + => (RIO env () -> IO ()) -> TestOpts -> [Text] -> ActionContext - -> ExecuteEnv m + -> ExecuteEnv -> Task -> InstalledMap - -> m () + -> RIO env () 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'. @@ -1543,6 +1648,7 @@ , esIncludeGhcPackagePath = True , esStackExe = True , esLocaleUtf8 = False + , esKeepGhcRts = False } if exists then do @@ -1550,8 +1656,8 @@ when needHpc $ do tixexists <- doesFileExist tixPath when tixexists $ - $logWarn ("Removing HPC file " <> T.pack (toFilePath tixPath)) - ignoringAbsence (removeFile tixPath) + logWarn ("Removing HPC file " <> T.pack (toFilePath tixPath)) + liftIO $ ignoringAbsence (removeFile tixPath) let args = toAdditionalArgs topts argsDisplay = case args of @@ -1562,7 +1668,7 @@ -- Clear "Progress: ..." message before -- redirecting output. when (isNothing mlogFile) $ do - $logStickyDone "" + logStickyDone "" liftIO $ hFlush stdout liftIO $ hFlush stderr @@ -1584,17 +1690,22 @@ ec <- liftIO $ waitForProcess ph -- Add a trailing newline, incase the test -- output didn't finish with a newline. - when (isNothing mlogFile) ($logInfo "") + when (isNothing mlogFile) (logInfo "") -- Move the .tix file out of the package -- directory into the hpc work dir, for -- tidiness. when needHpc $ updateTixFile (packageName package) tixPath testName' - return $ case ec of - ExitSuccess -> Map.empty - _ -> Map.singleton testName $ Just ec + let announceResult result = announce $ "Test suite " <> testName <> " " <> result + case ec of + ExitSuccess -> do + announceResult "passed" + return Map.empty + _ -> do + announceResult "failed" + return $ Map.singleton testName (Just ec) else do - $logError $ T.pack $ show $ TestSuiteExeMissing + logError $ T.pack $ show $ TestSuiteExeMissing (packageBuildType package == Just C.Simple) exeName (packageNameString (packageName package)) @@ -1623,15 +1734,15 @@ bs -- | Implements running a package's benchmarks. -singleBench :: (StackM env m, HasEnvConfig env) - => (m () -> IO ()) +singleBench :: HasEnvConfig env + => (RIO env () -> IO ()) -> BenchmarkOpts -> [Text] -> ActionContext - -> ExecuteEnv m + -> ExecuteEnv -> Task -> InstalledMap - -> m () + -> RIO env () singleBench runInBase beopts benchesToRun ac ee task installedMap = do (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 @@ -1655,11 +1766,11 @@ data ConvertPathsToAbsolute = ConvertPathsToAbsolute | KeepPathsAsIs -- | Strip Template Haskell "Loading package" lines and making paths absolute. -mungeBuildOutput :: forall m. (MonadIO m, MonadCatch m, MonadBaseControl IO m) +mungeBuildOutput :: forall m. MonadIO m => ExcludeTHLoading -- ^ exclude TH loading? -> ConvertPathsToAbsolute -- ^ convert paths to absolute? -> Path Abs Dir -- ^ package's root directory - -> CompilerVersion -- ^ compiler we're building with + -> CompilerVersion 'CVActual -- ^ compiler we're building with -> ConduitM Text Text m () mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $ CT.lines @@ -1700,9 +1811,9 @@ let (x, y) = T.break (== ':') bs mabs <- if isValidSuffix y - then liftM (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $ + then liftIO $ liftM (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $ forgivingAbsence (resolveFile pkgDir (T.unpack $ T.dropWhile isSpace x)) `catch` - \(_ :: PathParseException) -> return Nothing + \(_ :: PathException) -> return Nothing else return Nothing case mabs of Nothing -> return bs @@ -1742,40 +1853,57 @@ -- Do not pass `-hpcdir` as GHC option if the coverage is not enabled. -- This helps running stack-compiled programs with dynamic interpreters like `hint`. -- Cfr: https://github.com/commercialhaskell/stack/issues/997 -extraBuildOptions :: (StackM env m, HasEnvConfig env) => WhichCompiler -> BuildOpts -> m [String] +extraBuildOptions :: (HasEnvConfig env, HasRunner env) + => WhichCompiler -> BuildOpts -> RIO env [String] extraBuildOptions wc bopts = do + colorOpt <- appropriateGhcColorFlag let ddumpOpts = " -ddump-hi -ddump-to-file" optsFlag = compilerOptionsCabalFlag wc + baseOpts = ddumpOpts ++ maybe "" (" " ++) colorOpt if toCoverage (boptsTestOpts bopts) then do hpcIndexDir <- toFilePathNoTrailingSep <$> hpcRelativeDir - return [optsFlag, "-hpcdir " ++ hpcIndexDir ++ ddumpOpts] + return [optsFlag, "-hpcdir " ++ hpcIndexDir ++ baseOpts] else - return [optsFlag, ddumpOpts] + return [optsFlag, baseOpts] -- Library and executable build components. -primaryComponentOptions :: LocalPackage -> [String] -primaryComponentOptions lp = ["lib:" ++ packageNameString (packageName (lpPackage lp)) +primaryComponentOptions :: Map Text ExecutableBuildStatus -> LocalPackage -> [String] +primaryComponentOptions executableBuildStatuses 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) + (case packageLibraries (lpPackage lp) of + NoLibraries -> [] + HasLibraries names -> + map T.unpack + $ T.append "lib:" (packageNameText (packageName (lpPackage lp))) + : map (T.append "flib:") (Set.toList names)) ++ + map (T.unpack . T.append "exe:") (Set.toList $ exesToBuild executableBuildStatuses 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) +-- | History of this function: +-- +-- * Normally it would do either all executables or if the user +-- specified requested components, just build them. Afterwards, due +-- to this Cabal bug , +-- we had to make Stack build all executables every time. +-- +-- * In this +-- was flagged up as very undesirable behavior on a large project, +-- hence the behavior below that we build all executables once +-- (modulo success), and thereafter pay attention to user-wanted +-- components. +-- +exesToBuild :: Map Text ExecutableBuildStatus -> LocalPackage -> Set Text +exesToBuild executableBuildStatuses lp = + if cabalIsSatisfied executableBuildStatuses && lpWanted lp + then exeComponents (lpComponents lp) + else packageExes (lpPackage lp) +-- | Do the current executables satisfy Cabal's bugged out requirements? +cabalIsSatisfied :: Map k ExecutableBuildStatus -> Bool +cabalIsSatisfied = all (== ExecutableBuilt) . M.elems + -- Test-suite and benchmark build components. finalComponentOptions :: LocalPackage -> [String] finalComponentOptions lp = @@ -1786,8 +1914,8 @@ taskComponents :: Task -> Set NamedComponent taskComponents task = case taskType task of - TTLocal lp -> lpComponents lp - TTUpstream{} -> Set.empty + TTFiles lp _ -> lpComponents lp -- FIXME probably just want Local, maybe even just lpWanted + TTIndex{} -> 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 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -16,31 +17,17 @@ , shouldHaddockDeps ) where -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 Stack.Prelude 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.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Maybe.Extra (mapMaybeM) -import Data.Monoid ((<>)) -import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) import qualified Data.Text as T import Data.Time (UTCTime) import Path import Path.Extra import Path.IO -import Prelude import Stack.PackageDump import Stack.PrettyPrint import Stack.Types.Build @@ -50,21 +37,19 @@ import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT (StackM) -import Stack.Types.StringError +import Stack.Types.Runner import qualified System.FilePath as FP -import System.IO.Error (isDoesNotExistError) import System.Process.Read import Web.Browser (openBrowser) openHaddocksInBrowser - :: StackM env m + :: HasRunner env => BaseConfigOpts -> Map PackageName (PackageIdentifier, InstallLocation) -- ^ Available packages and their locations for the current project -> Set PackageName -- ^ Build targets as determined by 'Stack.Build.Source.loadSourceMap' - -> m () + -> RIO env () openHaddocksInBrowser bco pkgLocations buildTargets = do let cliTargets = (boptsCLITargets . bcoBuildOptsCLI) bco getDocIndex = do @@ -91,13 +76,13 @@ if exists then return docFile else do - $logWarn $ + logWarn $ "Expected to find documentation at " <> T.pack (toFilePath docFile) <> ", but that file is missing. Opening doc index instead." getDocIndex _ -> getDocIndex - $prettyInfo $ "Opening" <+> display docFile <+> "in the browser." + prettyInfo $ "Opening" <+> display docFile <+> "in the browser." _ <- liftIO $ openBrowser (toFilePath docFile) return () @@ -119,7 +104,7 @@ -- | Generate Haddock index and contents for local packages. generateLocalHaddockIndex - :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> BaseConfigOpts @@ -138,14 +123,14 @@ "local packages" envOverride wc - (boptsHaddockOpts (bcoBuildOpts bco)) + bco dumpPackages "." (localDocDir bco) -- | Generate Haddock index and contents for local packages and their dependencies. generateDepsHaddockIndex - :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> BaseConfigOpts @@ -161,7 +146,7 @@ "local packages and dependencies" envOverride wc - (boptsHaddockOpts (bcoBuildOpts bco)) + bco deps ".." depDocDir @@ -190,7 +175,7 @@ -- | Generate Haddock index and contents for all snapshot packages. generateSnapHaddockIndex - :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> BaseConfigOpts @@ -202,23 +187,23 @@ "snapshot packages" envOverride wc - (boptsHaddockOpts (bcoBuildOpts bco)) + bco (Map.elems snapshotDumpPkgs ++ Map.elems globalDumpPkgs) "." (snapDocDir bco) -- | Generate Haddock index and contents for specified packages. generateHaddockIndex - :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m) + :: (MonadUnliftIO m, MonadLogger m) => Text -> EnvOverride -> WhichCompiler - -> HaddockOpts + -> BaseConfigOpts -> [DumpPackage () () ()] -> FilePath -> Path Abs Dir -> m () -generateHaddockIndex descr envOverride wc hdopts dumpPackages docRelFP destDir = do +generateHaddockIndex descr envOverride wc bco dumpPackages docRelFP destDir = do ensureDir destDir interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages unless (null interfaceOpts) $ do @@ -231,7 +216,7 @@ or [mt > indexModTime | (_,mt,_,_) <- interfaceOpts] if needUpdate then do - $logInfo + logInfo (T.concat ["Updating Haddock index for ", descr, " in\n", T.pack (toFilePath destIndexFile)]) liftIO (mapM_ copyPkgDocs interfaceOpts) @@ -239,11 +224,13 @@ (Just destDir) envOverride (haddockExeName wc) - (hoAdditionalArgs hdopts ++ + (map (("--optghc=-package-db=" ++ ) . toFilePathNoTrailingSep) + [bcoSnapDB bco, bcoLocalDB bco] ++ + hoAdditionalArgs (boptsHaddockOpts (bcoBuildOpts bco)) ++ ["--gen-contents", "--gen-index"] ++ [x | (xs,_,_,_) <- interfaceOpts, x <- xs]) else - $logInfo + logInfo (T.concat ["Haddock index for ", descr, " already up to date at:\n", T.pack (toFilePath destIndexFile)]) where @@ -273,8 +260,6 @@ , srcInterfaceModTime , srcInterfaceAbsFile , destInterfaceAbsFile ) - tryGetModificationTime :: Path Abs File -> 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@ diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -- Determine which packages are already installed module Stack.Build.Installed ( InstalledMap @@ -11,29 +11,19 @@ , getInstalled ) where -import Control.Applicative -import Control.Arrow -import Control.Monad -import Control.Monad.Logger import Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Foldable as F -import Data.Function import qualified Data.HashSet as HashSet import Data.List -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 Path -import Prelude hiding (FilePath, writeFile) import Stack.Build.Cache import Stack.Constants -import Stack.GhcPkg import Stack.PackageDump +import Stack.Prelude import Stack.Types.Build import Stack.Types.Compiler import Stack.Types.Config @@ -42,8 +32,8 @@ import Stack.Types.PackageDump import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT import Stack.Types.Version +import System.Process.Read (EnvOverride) -- | Options for 'getInstalled'. data GetInstalledOpts = GetInstalledOpts @@ -56,17 +46,18 @@ } -- | Returns the new InstalledMap and all of the locally registered packages. -getInstalled :: (StackM env m, HasEnvConfig env, PackageInstallInfo pii) +getInstalled :: HasEnvConfig env => EnvOverride -> GetInstalledOpts - -> Map PackageName pii -- ^ does not contain any installed information - -> m ( InstalledMap + -> Map PackageName PackageSource -- ^ does not contain any installed information + -> RIO env + ( InstalledMap , [DumpPackage () () ()] -- globally installed , [DumpPackage () () ()] -- snapshot installed , [DumpPackage () () ()] -- locally installed ) getInstalled menv opts sourceMap = do - $logDebug "Finding out which packages are already installed" + logDebug "Finding out which packages are already installed" snapDBPath <- packageDatabaseDeps localDBPath <- packageDatabaseLocal extraDBPaths <- packageDatabaseExtra @@ -126,14 +117,14 @@ -- The goal is to ascertain that the dependencies for a package are present, -- that it has profiling if necessary, and that it matches the version and -- location needed by the SourceMap -loadDatabase :: (StackM env m, HasEnvConfig env, PackageInstallInfo pii) +loadDatabase :: HasEnvConfig env => EnvOverride -> GetInstalledOpts -> Maybe InstalledCache -- ^ if Just, profiling or haddock is required - -> Map PackageName pii -- ^ to determine which installed things we should include + -> Map PackageName PackageSource -- ^ to determine which installed things we should include -> Maybe (InstalledPackageLocation, Path Abs Dir) -- ^ package database, Nothing for global -> [LoadHelper] -- ^ from parent databases - -> m ([LoadHelper], [DumpPackage () () ()]) + -> RIO env ([LoadHelper], [DumpPackage () () ()]) loadDatabase menv opts mcache sourceMap mdb lhs0 = do wc <- view $ actualCompilerVersionL.to whichCompiler (lhs1', dps) <- ghcPkgDump menv wc (fmap snd (maybeToList mdb)) @@ -186,7 +177,7 @@ -- Allow some packages in the ghcjs global DB to have the wrong -- versions. Treat them as wired-ins by setting deps to []. | fst (lhPair lh) `HashSet.member` ghcjsBootPackages = do - $logWarn $ T.concat + logWarn $ T.concat [ "Ignoring that the GHCJS boot package \"" , packageNameText (fst (lhPair lh)) , "\" has a different version, " @@ -196,7 +187,7 @@ ] return (Just lh) processLoadResult mdb _ (reason, lh) = do - $logDebug $ T.concat $ + logDebug $ T.concat $ [ "Ignoring package " , packageNameText (fst (lhPair lh)) ] ++ @@ -231,10 +222,9 @@ -- | Check if a can be included in the set of installed packages or not, based -- on the package selections made by the user. This does not perform any -- dirtiness or flag change checks. -isAllowed :: PackageInstallInfo pii - => GetInstalledOpts +isAllowed :: GetInstalledOpts -> Maybe InstalledCache - -> Map PackageName pii + -> Map PackageName PackageSource -> Maybe InstalledPackageLocation -> DumpPackage Bool Bool Bool -> Allowed @@ -288,7 +278,7 @@ if name `HashSet.member` wiredInPackages then [] else dpDepends dp - , lhPair = (name, (toPackageLocation mloc, Library ident gid)) + , lhPair = (name, (toPackageLocation mloc, Library ident gid (dpLicense dp))) } where gid = dpGhcPkgId dp diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} @@ -12,25 +10,12 @@ ( loadSourceMap , loadSourceMapFull , SourceMap - , PackageSource (..) , getLocalFlags , getGhcOptions - , getLocalPackageViews - , parseTargetsFromBuildOpts - , parseTargetsFromBuildOptsWith , addUnlistedToBuildCache - , getDefaultPackageConfig - , getPackageConfig ) where -import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Exception (assert, catch) -import Control.Monad hiding (sequence) -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Reader (MonadReader) -import Control.Monad.Trans.Resource +import Stack.Prelude import Crypto.Hash (Digest, SHA256(..)) import Crypto.Hash.Conduit (sinkHash) import qualified Data.ByteArray as Mem (convert) @@ -38,163 +23,96 @@ import Data.Conduit (($$), ZipSink (..)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL -import Data.Either -import Data.Function import qualified Data.HashSet as HashSet import Data.List import qualified Data.Map as Map -import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T -import Data.Traversable (sequence) -import Distribution.Package (pkgName, pkgVersion) -import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription) -import qualified Distribution.PackageDescription as C -import Path -import Path.IO -import Prelude hiding (sequence) import Stack.Build.Cache import Stack.Build.Target -import Stack.BuildPlan (shadowMiniBuildPlan) import Stack.Config (getLocalPackages) import Stack.Constants (wiredInPackages) import Stack.Package -import Stack.PackageIndex (getPackageVersions) +import Stack.PackageLocation import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.Package import Stack.Types.PackageName -import Stack.Types.Resolver -import Stack.Types.StackT -import Stack.Types.Version import qualified System.Directory as D import System.FilePath (takeFileName) -import System.IO (withBinaryFile, IOMode (ReadMode)) import System.IO.Error (isDoesNotExistError) -- | Like 'loadSourceMapFull', but doesn't return values that aren't as -- commonly needed. -loadSourceMap :: (StackM env m, HasEnvConfig env) +loadSourceMap :: HasEnvConfig env => NeedTargets -> BuildOptsCLI - -> m ( [LocalPackage] - , SourceMap - ) + -> RIO env ([LocalPackage], SourceMap) loadSourceMap needTargets boptsCli = do - (_, _, locals, _, _, sourceMap) <- loadSourceMapFull needTargets boptsCli + (_, _, locals, _, sourceMap) <- loadSourceMapFull needTargets boptsCli return (locals, sourceMap) -- | Given the build commandline options, does the following: -- -- * Parses the build targets. -- --- * Loads the 'MiniBuildPlan' from the resolver, with extra-deps +-- * Loads the 'LoadedSnapshot' from the resolver, with extra-deps -- shadowing any packages that should be built locally. -- -- * Loads up the 'LocalPackage' info. -- -- * Builds a 'SourceMap', which contains info for all the packages that -- will be involved in the build. -loadSourceMapFull :: (StackM env m, HasEnvConfig env) +loadSourceMapFull :: HasEnvConfig env => NeedTargets -> BuildOptsCLI - -> m ( Map PackageName SimpleTarget - , MiniBuildPlan - , [LocalPackage] - , Set PackageName -- non-local targets - , Map PackageName Version -- extra-deps from configuration and cli + -> RIO env + ( Map PackageName Target + , LoadedSnapshot + , [LocalPackage] -- FIXME do we really want this? it's in the SourceMap + , Set PackageName -- non-project targets , SourceMap ) loadSourceMapFull needTargets boptsCli = do bconfig <- view buildConfigL - rawLocals <- getLocalPackageViews - (mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOptsWith rawLocals needTargets boptsCli - - -- Extend extra-deps to encompass targets requested on the command line - -- that are not in the snapshot. - extraDeps0 <- extendExtraDeps - (bcExtraDeps bconfig) - cliExtraDeps - (Map.keysSet $ Map.filter (== STUnknown) targets) - - locals <- mapM (loadLocalPackage boptsCli targets) $ Map.toList rawLocals - checkFlagsUsed boptsCli locals extraDeps0 (mbpPackages mbp0) + (ls, localDeps, targets) <- parseTargets needTargets boptsCli + lp <- getLocalPackages + locals <- mapM (loadLocalPackage True boptsCli targets) $ Map.toList $ lpProject lp + checkFlagsUsed boptsCli locals localDeps (lsPackages ls) checkComponentsBuildable locals - let - -- loadLocals returns PackageName (foo) and PackageIdentifier (bar-1.2.3) targets separately; - -- here we combine them into nonLocalTargets. This is one of the - -- return values of this function. - nonLocalTargets :: Set PackageName - nonLocalTargets = - Map.keysSet $ Map.filter (not . isLocal) targets - where - isLocal (STLocalComps _) = True - isLocal STLocalAll = True - isLocal STUnknown = False - isLocal STNonLocal = False - - shadowed = Map.keysSet rawLocals <> Map.keysSet extraDeps0 - - -- Ignores all packages in the MiniBuildPlan that depend on any - -- local packages or extra-deps. All packages that have - -- transitive dependenceis on these packages are treated as - -- extra-deps (extraDeps1). - (mbp, extraDeps1) = shadowMiniBuildPlan mbp0 shadowed - - -- Combine the extra-deps with the ones implicitly shadowed. - extraDeps2 = Map.union - (Map.map (\v -> (v, Map.empty, [])) extraDeps0) - (Map.map (\mpi -> (mpiVersion mpi, mpiFlags mpi, mpiGhcOptions mpi)) extraDeps1) - - -- Add flag and ghc-option settings from the config file / cli - extraDeps3 = Map.mapWithKey - (\n (v, flags0, ghcOptions0) -> - let flags = - case ( Map.lookup (Just n) $ boptsCLIFlags boptsCli - , Map.lookup Nothing $ boptsCLIFlags boptsCli - , Map.lookup n $ unPackageFlags $ bcFlags bconfig - ) of - -- Didn't have any flag overrides, fall back to the flags - -- defined in the snapshot. - (Nothing, Nothing, Nothing) -> flags0 - -- Either command line flag for this package, general - -- command line flag, or flag in stack.yaml is defined. - -- Take all of those and ignore the snapshot flags. - (x, y, z) -> Map.unions - [ fromMaybe Map.empty x - , fromMaybe Map.empty y - , fromMaybe Map.empty z - ] - ghcOptions = - ghcOptions0 ++ - getGhcOptions bconfig boptsCli n False False - -- currently have no ability for extra-deps to specify their - -- cabal file hashes - in PSUpstream v Local flags ghcOptions Nothing) - extraDeps2 + -- TODO for extra sanity, confirm that the targets we threw away are all TargetAll + let nonProjectTargets = Map.keysSet targets `Set.difference` Map.keysSet (lpProject lp) - -- Combine the local packages, extra-deps, and MiniBuildPlan into + -- Combine the local packages, extra-deps, and LoadedSnapshot into -- one unified source map. - let sourceMap = Map.unions - [ Map.fromList $ flip map locals $ \lp -> - let p = lpPackage lp - in (packageName p, PSLocal lp) - , extraDeps3 - , flip Map.mapWithKey (mbpPackages mbp) $ \n mpi -> - let configOpts = getGhcOptions bconfig boptsCli n False False - in PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi) (mpiGhcOptions mpi ++ configOpts) (mpiGitSHA1 mpi) - ] + let goLPI loc n lpi = do + let configOpts = getGhcOptions bconfig boptsCli n False False + case lpiLocation lpi of + -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon + PLIndex pir -> return $ PSIndex loc (lpiFlags lpi) configOpts pir + PLOther pl -> do + root <- view projectRootL + lpv <- parseSingleCabalFile root True pl + lp' <- loadLocalPackage False boptsCli targets (n, lpv) + return $ PSFiles lp' loc + sourceMap' <- Map.unions <$> sequence + [ return $ Map.fromList $ map (\lp' -> (packageName $ lpPackage lp', PSFiles lp' Local)) locals + , sequence $ Map.mapWithKey (goLPI Local) localDeps + , sequence $ Map.mapWithKey (goLPI Snap) (lsPackages ls) + ] + let sourceMap = sourceMap' `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) - return (targets, mbp, locals, nonLocalTargets, extraDeps0, sourceMap) + return + ( targets + , ls + , locals + , nonProjectTargets + , sourceMap + ) -- | All flags for a local package. getLocalFlags @@ -205,7 +123,7 @@ getLocalFlags bconfig boptsCli name = Map.unions [ Map.findWithDefault Map.empty (Just name) cliFlags , Map.findWithDefault Map.empty Nothing cliFlags - , Map.findWithDefault Map.empty name (unPackageFlags (bcFlags bconfig)) + , Map.findWithDefault Map.empty name (bcFlags bconfig) ] where cliFlags = boptsCLIFlags boptsCli @@ -214,10 +132,17 @@ -- configuration and commandline. getGhcOptions :: BuildConfig -> BuildOptsCLI -> PackageName -> Bool -> Bool -> [Text] getGhcOptions bconfig boptsCli name isTarget isLocal = concat - [ ghcOptionsFor name (configGhcOptions config) + [ Map.findWithDefault [] AGOEverything (configGhcOptionsByCat config) + , if isLocal + then Map.findWithDefault [] AGOLocals (configGhcOptionsByCat config) + else [] + , if isTarget + then Map.findWithDefault [] AGOTargets (configGhcOptionsByCat config) + else [] + , Map.findWithDefault [] name (configGhcOptionsByName config) , concat [["-fhpc"] | isLocal && toCoverage (boptsTestOpts bopts)] , if boptsLibProfile bopts || boptsExeProfile bopts - then ["-auto-all","-caf-all"] + then ["-fprof-auto","-fprof-cafs"] else [] , if not $ boptsLibStrip bopts || boptsExeStrip bopts then ["-g"] @@ -235,137 +160,6 @@ AGOLocals -> isLocal AGOEverything -> True --- | Use the build options and environment to parse targets. --- --- If the local packages views are already known, use 'parseTargetsFromBuildOptsWith' --- instead. --- --- Along with the 'Map' of targets, this yields the loaded --- 'MiniBuildPlan' for the resolver, as well as a Map of extra-deps --- derived from the commandline. These extra-deps targets come from when --- the user specifies a particular package version on the commonadline, --- or when a flag is specified for a snapshot package. -parseTargetsFromBuildOpts - :: (StackM env m, HasEnvConfig env) - => NeedTargets - -> BuildOptsCLI - -> m (MiniBuildPlan, M.Map PackageName Version, M.Map PackageName SimpleTarget) -parseTargetsFromBuildOpts needTargets boptscli = do - rawLocals <- getLocalPackageViews - parseTargetsFromBuildOptsWith rawLocals needTargets boptscli - -parseTargetsFromBuildOptsWith - :: (StackM env m, HasEnvConfig env) - => Map PackageName (LocalPackageView, GenericPackageDescription) - -- ^ Local package views - -> NeedTargets - -> BuildOptsCLI - -> m (MiniBuildPlan, M.Map PackageName Version, M.Map PackageName SimpleTarget) -parseTargetsFromBuildOptsWith rawLocals needTargets boptscli = do - $logDebug "Parsing the targets" - bconfig <- view buildConfigL - mbp0 <- - case bcResolver bconfig of - ResolverCompiler _ -> do - -- We ignore the resolver version, as it might be - -- GhcMajorVersion, and we want the exact version - -- we're using. - version <- view actualCompilerVersionL - return MiniBuildPlan - { mbpCompilerVersion = version - , mbpPackages = Map.empty - } - _ -> return (bcWantedMiniBuildPlan bconfig) - workingDir <- getCurrentDir - - let snapshot = mpiVersion <$> mbpPackages mbp0 - flagExtraDeps <- convertSnapshotToExtra - snapshot - (bcExtraDeps bconfig) - rawLocals - (catMaybes $ Map.keys $ boptsCLIFlags boptscli) - - (cliExtraDeps, targets) <- - parseTargets - needTargets - (bcImplicitGlobal bconfig) - snapshot - (flagExtraDeps <> bcExtraDeps bconfig) - (fst <$> rawLocals) - workingDir - (boptsCLITargets boptscli) - return (mbp0, cliExtraDeps <> flagExtraDeps, targets) - --- | For every package in the snapshot which is referenced by a flag, give the --- user a warning and then add it to extra-deps. -convertSnapshotToExtra - :: MonadLogger m - => Map PackageName Version -- ^ snapshot - -> Map PackageName Version -- ^ extra-deps - -> Map PackageName a -- ^ locals - -> [PackageName] -- ^ packages referenced by a flag - -> m (Map PackageName Version) -convertSnapshotToExtra snapshot extra0 locals = go Map.empty - where - go !extra [] = return extra - go extra (flag:flags) - | Just _ <- Map.lookup flag extra0 = go extra flags - | flag `Map.member` locals = go extra flags - | otherwise = case Map.lookup flag snapshot of - Nothing -> go extra flags - Just version -> do - $logWarn $ T.concat - [ "- Implicitly adding " - , T.pack $ packageNameString flag - , " to extra-deps based on command line flag" - ] - go (Map.insert flag version extra) flags - --- | Parse out the local package views for the current project -getLocalPackageViews :: (StackM env m, HasEnvConfig env) - => m (Map PackageName (LocalPackageView, GenericPackageDescription)) -getLocalPackageViews = do - $logDebug "Parsing the cabal files of the local packages" - packages <- getLocalPackages - locals <- forM (Map.toList packages) $ \(dir, treatLikeExtraDep) -> do - cabalfp <- findOrGenerateCabalFile dir - (warnings,gpkg) <- readPackageUnresolved cabalfp - mapM_ (printCabalFileWarning cabalfp) warnings - let cabalID = package $ packageDescription gpkg - name = fromCabalPackageName $ pkgName cabalID - checkCabalFileName name cabalfp - let lpv = LocalPackageView - { lpvVersion = fromCabalVersion $ pkgVersion cabalID - , lpvRoot = dir - , lpvCabalFP = cabalfp - , lpvExtraDep = treatLikeExtraDep - , lpvComponents = getNamedComponents gpkg - } - return (name, (lpv, gpkg)) - checkDuplicateNames locals - return $ Map.fromList locals - where - getNamedComponents gpkg = Set.fromList $ concat - [ maybe [] (const [CLib]) (C.condLibrary gpkg) - , go CExe C.condExecutables - , go CTest C.condTestSuites - , go CBench C.condBenchmarks - ] - where - go wrapper f = map (wrapper . T.pack . fst) $ f gpkg - --- | Check if there are any duplicate package names and, if so, throw an --- exception. -checkDuplicateNames :: MonadThrow m => [(PackageName, (LocalPackageView, gpd))] -> m () -checkDuplicateNames locals = - case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map toPair locals of - [] -> return () - x -> throwM $ DuplicateLocalPackageNames x - where - toPair (pn, (lpv, _)) = (pn, [lpvRoot lpv]) - hasMultiples (_, _:_:_) = True - hasMultiples _ = False - splitComponents :: [NamedComponent] -> (Set Text, Set Text, Set Text) splitComponents = @@ -380,31 +174,55 @@ -- | Upgrade the initial local package info to a full-blown @LocalPackage@ -- based on the selected components loadLocalPackage - :: forall m env. (StackM env m, HasEnvConfig env) - => BuildOptsCLI - -> Map PackageName SimpleTarget - -> (PackageName, (LocalPackageView, GenericPackageDescription)) - -> m LocalPackage -loadLocalPackage boptsCli targets (name, (lpv, gpkg)) = do + :: forall env. HasEnvConfig env + => Bool + -- ^ Should this be treated as part of $locals? False for extra-deps. + -- + -- See: https://github.com/commercialhaskell/stack/issues/3574#issuecomment-346512821 + -> BuildOptsCLI + -> Map PackageName Target + -> (PackageName, LocalPackageView) + -> RIO env LocalPackage +loadLocalPackage isLocal boptsCli targets (name, lpv) = do let mtarget = Map.lookup name targets - config <- getPackageConfig boptsCli name (isJust mtarget) True + config <- getPackageConfig boptsCli name (isJust mtarget) isLocal bopts <- view buildOptsL - let (exes, tests, benches) = + let (exeCandidates, testCandidates, benchCandidates) = case mtarget of - Just (STLocalComps comps) -> splitComponents $ Set.toList comps - Just STLocalAll -> + Just (TargetComps comps) -> splitComponents $ Set.toList comps + Just (TargetAll _packageType) -> ( packageExes pkg - , if boptsTests bopts && not (lpvExtraDep lpv) + , if boptsTests bopts then Map.keysSet (packageTests pkg) else Set.empty - , if boptsBenchmarks bopts && not (lpvExtraDep lpv) + , if boptsBenchmarks bopts then packageBenchmarks pkg else Set.empty ) - Just STNonLocal -> assert False mempty - Just STUnknown -> assert False mempty Nothing -> mempty + -- See https://github.com/commercialhaskell/stack/issues/2862 + isWanted = case mtarget of + Nothing -> False + -- FIXME: When issue #1406 ("stack 0.1.8 lost ability to + -- build individual executables or library") is resolved, + -- 'hasLibrary' is only relevant if the library is + -- part of the target spec. + Just _ -> + let hasLibrary = + case packageLibraries pkg of + NoLibraries -> False + HasLibraries _ -> True + in hasLibrary || not (Set.null nonLibComponents) + + filterSkippedComponents = Set.filter (not . (`elem` boptsSkipComponents bopts)) + + (exes, tests, benches) = (filterSkippedComponents exeCandidates, + filterSkippedComponents testCandidates, + filterSkippedComponents benchCandidates) + + nonLibComponents = toComponents exes tests benches + toComponents e t b = Set.unions [ Set.map CExe e , Set.map CTest t @@ -439,6 +257,7 @@ -- This allows us to do an optimization where these are passed -- if the deps are present. This can avoid doing later -- unnecessary reconfigures. + gpkg = lpvGPD lpv pkg = resolvePackage config gpkg btpkg | Set.null tests && Set.null benches = Nothing @@ -447,8 +266,9 @@ benchpkg = resolvePackage benchconfig gpkg mbuildCache <- tryGetBuildCache $ lpvRoot lpv - (files,_) <- getPackageFilesSimple pkg (lpvCabalFP lpv) + (files,_) <- getPackageFilesForTargets pkg (lpvCabalFP lpv) nonLibComponents + (dirtyFiles, newBuildCache) <- checkBuildCache (fromMaybe Map.empty mbuildCache) (Set.toList files) @@ -469,8 +289,8 @@ , lpNewBuildCache = newBuildCache , lpCabalFile = lpvCabalFP lpv , lpDir = lpvRoot lpv - , lpWanted = isJust mtarget - , lpComponents = toComponents exes tests benches + , lpWanted = isWanted + , lpComponents = nonLibComponents -- TODO: refactor this so that it's easier to be sure that these -- components are indeed unbuildable. -- @@ -481,6 +301,7 @@ (exes `Set.difference` packageExes pkg) (tests `Set.difference` Map.keysSet (packageTests pkg)) (benches `Set.difference` packageBenchmarks pkg) + , lpLocation = lpvLoc lpv } -- | Ensure that the flags specified in the stack.yaml file and on the command @@ -488,7 +309,7 @@ checkFlagsUsed :: (MonadThrow m, MonadReader env m, HasBuildConfig env) => BuildOptsCLI -> [LocalPackage] - -> Map PackageName extraDeps -- ^ extra deps + -> Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) -- ^ local deps -> Map PackageName snapshot -- ^ snapshot, for error messages -> m () checkFlagsUsed boptsCli lps extraDeps snapshot = do @@ -497,21 +318,21 @@ -- Check if flags specified in stack.yaml and the command line are -- used, see https://github.com/commercialhaskell/stack/issues/617 let flags = map (, FSCommandLine) [(k, v) | (Just k, v) <- Map.toList $ boptsCLIFlags boptsCli] - ++ map (, FSStackYaml) (Map.toList $ unPackageFlags $ bcFlags bconfig) + ++ map (, FSStackYaml) (Map.toList $ bcFlags bconfig) localNameMap = Map.fromList $ map (packageName . lpPackage &&& lpPackage) lps checkFlagUsed ((name, userFlags), source) = case Map.lookup name localNameMap of -- Package is not available locally Nothing -> - case Map.lookup name extraDeps of + if Map.member name extraDeps + -- We don't check for flag presence for extra deps + then Nothing -- Also not in extra-deps, it's an error - Nothing -> + else case Map.lookup name snapshot of Nothing -> Just $ UFNoPackage source name Just _ -> Just $ UFSnapshot name - -- We don't check for flag presence for extra deps - Just _ -> Nothing -- Package exists locally, let's check if the flags are defined Just pkg -> let unused = Set.difference (Map.keysSet userFlags) (packageDefinedFlags pkg) @@ -528,41 +349,6 @@ $ InvalidFlagSpecification $ Set.fromList unusedFlags --- | Add in necessary packages to extra dependencies --- --- Originally part of https://github.com/commercialhaskell/stack/issues/272, --- this was then superseded by --- https://github.com/commercialhaskell/stack/issues/651 -extendExtraDeps - :: (StackM env m, HasBuildConfig env) - => Map PackageName Version -- ^ original extra deps - -> Map PackageName Version -- ^ package identifiers from the command line - -> Set PackageName -- ^ all packages added on the command line - -> m (Map PackageName Version) -- ^ new extradeps -extendExtraDeps extraDeps0 cliExtraDeps unknowns = do - (errs, unknowns') <- fmap partitionEithers $ mapM addUnknown $ Set.toList unknowns - case errs of - [] -> return $ Map.unions $ extraDeps1 : unknowns' - _ -> do - bconfig <- view buildConfigL - throwM $ UnknownTargets - (Set.fromList errs) - Map.empty -- TODO check the cliExtraDeps for presence in index - (bcStackYaml bconfig) - where - extraDeps1 = Map.union extraDeps0 cliExtraDeps - addUnknown pn = do - case Map.lookup pn extraDeps1 of - Just _ -> return (Right Map.empty) - Nothing -> do - mlatestVersion <- getLatestVersion pn - case mlatestVersion of - Just v -> return (Right $ Map.singleton pn v) - Nothing -> return (Left pn) - getLatestVersion pn = do - vs <- getPackageVersions pn - return (fmap fst (Set.maxView vs)) - -- | Compare the current filesystem state to the cached information, and -- determine (1) if the files are dirty, and (2) the new cache values. checkBuildCache :: forall m. (MonadIO m) @@ -586,7 +372,7 @@ go fp _ _ | takeFileName fp == "cabal_macros.h" = return (Set.empty, Map.empty) -- Common case where it's in the cache and on the filesystem. go fp (Just modTime') (Just fci) - | fciModTime fci == modTime' = return (Set.empty, Map.empty) + | fciModTime fci == modTime' = return (Set.empty, Map.singleton fp fci) | otherwise = do newFci <- calcFci modTime' fp let isDirty = @@ -603,14 +389,15 @@ -- | Returns entries to add to the build cache for any newly found unlisted modules addUnlistedToBuildCache - :: (StackM env m, HasEnvConfig env) + :: HasEnvConfig env => ModTime -> Package -> Path Abs File + -> Set NamedComponent -> Map FilePath a - -> m ([Map FilePath FileCacheInfo], [PackageWarning]) -addUnlistedToBuildCache preBuildTime pkg cabalFP buildCache = do - (files,warnings) <- getPackageFilesSimple pkg cabalFP + -> RIO env ([Map FilePath FileCacheInfo], [PackageWarning]) +addUnlistedToBuildCache preBuildTime pkg cabalFP nonLibComponents buildCache = do + (files,warnings) <- getPackageFilesForTargets pkg cabalFP nonLibComponents let newFiles = Set.toList $ Set.map toFilePath files `Set.difference` Map.keysSet buildCache @@ -628,16 +415,21 @@ return (Map.singleton fp newFci) else return Map.empty --- | Gets list of Paths for files in a package -getPackageFilesSimple - :: (StackM env m, HasEnvConfig env) - => Package -> Path Abs File -> m (Set (Path Abs File), [PackageWarning]) -getPackageFilesSimple pkg cabalFP = do - (_,compFiles,cabalFiles,warnings) <- +-- | Gets list of Paths for files relevant to a set of components in a package. +-- Note that the library component, if any, is always automatically added to the +-- set of components. +getPackageFilesForTargets + :: HasEnvConfig env + => Package -> Path Abs File -> Set NamedComponent -> RIO env (Set (Path Abs File), [PackageWarning]) +getPackageFilesForTargets pkg cabalFP components = do + (_,compFiles,otherFiles,warnings) <- getPackageFiles (packageFiles pkg) cabalFP - return - ( Set.map dotCabalGetPath (mconcat (M.elems compFiles)) <> cabalFiles - , warnings) + let filesForComponent cn = Set.map dotCabalGetPath + $ M.findWithDefault mempty cn compFiles + files = Set.unions + $ otherFiles + : map filesForComponent (Set.toList $ Set.insert CLib components) + return (files, warnings) -- | Get file modification time, if it exists. getModTimeMaybe :: MonadIO m => FilePath -> m (Maybe ModTime) @@ -677,20 +469,6 @@ | lp <- lps , c <- Set.toList (lpUnbuildable lp) ] - -getDefaultPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env) - => m PackageConfig -getDefaultPackageConfig = do - platform <- view platformL - compilerVersion <- view actualCompilerVersionL - return PackageConfig - { packageConfigEnableTests = False - , packageConfigEnableBenchmarks = False - , packageConfigFlags = M.empty - , packageConfigGhcOptions = [] - , packageConfigCompilerVersion = compilerVersion - , packageConfigPlatform = platform - } -- | Get 'PackageConfig' for package given its name. getPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env) diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -1,56 +1,125 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -- | Parsing command line targets +-- +-- There are two relevant data sources for performing this parsing: +-- the project configuration, and command line arguments. Project +-- configurations includes the resolver (defining a LoadedSnapshot of +-- global and snapshot packages), local dependencies, and project +-- packages. It also defines local flag overrides. +-- +-- The command line arguments specify both additional local flag +-- overrides and targets in their raw form. +-- +-- Flags are simple: we just combine CLI flags with config flags and +-- make one big map of flags, preferring CLI flags when present. +-- +-- Raw targets can be a package name, a package name with component, +-- just a component, or a package name and version number. We first +-- must resolve these raw targets into both simple targets and +-- additional dependencies. This works as follows: +-- +-- * If a component is specified, find a unique project package which +-- defines that component, and convert it into a name+component +-- target. +-- +-- * Ensure that all name+component values refer to valid components +-- in the given project package. +-- +-- * For names, check if the name is present in the snapshot, local +-- deps, or project packages. If it is not, then look up the most +-- recent version in the package index and convert to a +-- name+version. +-- +-- * For name+version, first ensure that the name is not used by a +-- project package. Next, if that name+version is present in the +-- snapshot or local deps _and_ its location is PLIndex, we have the +-- package. Otherwise, add to local deps with the appropriate +-- PLIndex. +-- +-- If in either of the last two bullets we added a package to local +-- deps, print a warning to the user recommending modifying the +-- extra-deps. +-- +-- Combine the various 'ResolveResults's together into 'Target' +-- values, by combining various components for a single package and +-- ensuring that no conflicting statements were made about targets. +-- +-- At this point, we now have a Map from package name to SimpleTarget, +-- and an updated Map of local dependencies. We still have the +-- aggregated flags, and the snapshot and project packages. +-- +-- Finally, we upgrade the snapshot by using +-- calculatePackagePromotion. module Stack.Build.Target ( -- * Types - ComponentName - , UnresolvedComponent (..) - , RawTarget (..) - , LocalPackageView (..) - , SimpleTarget (..) + Target (..) , NeedTargets (..) - -- * Parsers - , parseRawTarget + , PackageType (..) , parseTargets + -- * Convenience helpers + , gpdVersion + -- * Test suite exports + , parseRawTarget + , RawTarget (..) + , UnresolvedComponent (..) ) where -import Control.Applicative -import Control.Arrow (second) -import Control.Monad.Catch (MonadCatch, throwM) -import Control.Monad.IO.Class -import Data.Either (partitionEithers) -import Data.Foldable -import Data.List.Extra (groupSort) -import Data.List.NonEmpty (NonEmpty((:|))) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Map (Map) +import Stack.Prelude import qualified Data.Map as Map -import Data.Maybe (mapMaybe) -import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) import qualified Data.Text as T +import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription) import Path import Path.Extra (rejectMissingDir) import Path.IO -import Prelude hiding (concat, concatMap) -- Fix redundant import warnings +import Stack.Config (getLocalPackages) +import Stack.Fetch (withCabalLoader) +import Stack.PackageIndex +import Stack.PackageLocation +import Stack.Snapshot (calculatePackagePromotion) +import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -import Stack.Types.Config import Stack.Types.Build -import Stack.Types.Package +import Stack.Types.BuildPlan +import Stack.Types.GhcPkgId --- | The name of a component, which applies to executables, test suites, and benchmarks -type ComponentName = Text +-- | Do we need any targets? For example, `stack build` will fail if +-- no targets are provided. +data NeedTargets = NeedTargets | AllowNoTargets +--------------------------------------------------------------------------------- +-- Get the RawInput +--------------------------------------------------------------------------------- + +-- | Raw target information passed on the command line. newtype RawInput = RawInput { unRawInput :: Text } +getRawInput :: BuildOptsCLI -> Map PackageName LocalPackageView -> ([Text], [RawInput]) +getRawInput boptscli locals = + let textTargets' = boptsCLITargets boptscli + textTargets = + -- Handle the no targets case, which means we pass in the names of all project packages + if null textTargets' + then map packageNameText (Map.keys locals) + else textTargets' + in (textTargets', map RawInput textTargets) + +--------------------------------------------------------------------------------- +-- Turn RawInput into RawTarget +--------------------------------------------------------------------------------- + +-- | The name of a component, which applies to executables, test +-- suites, and benchmarks +type ComponentName = Text + -- | Either a fully resolved component, or a component name that could be -- either an executable, test, or benchmark data UnresolvedComponent @@ -60,23 +129,50 @@ -- | Raw command line input, without checking against any databases or list of -- locals. Does not deal with directories -data RawTarget (a :: RawTargetType) where - RTPackageComponent :: !PackageName -> !UnresolvedComponent -> RawTarget a - RTComponent :: !ComponentName -> RawTarget a - RTPackage :: !PackageName -> RawTarget a - RTPackageIdentifier :: !PackageIdentifier -> RawTarget 'HasIdents +data RawTarget + = RTPackageComponent !PackageName !UnresolvedComponent + | RTComponent !ComponentName + | RTPackage !PackageName + -- Explicitly _not_ supporting revisions on the command line. If + -- you want that, you should be modifying your stack.yaml! (In + -- fact, you should probably do that anyway, we're just letting + -- people be lazy, since we're Haskeletors.) + | RTPackageIdentifier !PackageIdentifier + deriving (Show, Eq) -deriving instance Show (RawTarget a) -deriving instance Eq (RawTarget a) -deriving instance Ord (RawTarget a) +-- | Same as @parseRawTarget@, but also takes directories into account. +parseRawTargetDirs :: MonadIO m + => Path Abs Dir -- ^ current directory + -> Map PackageName LocalPackageView + -> RawInput -- ^ raw target information from the commandline + -> m (Either Text [(RawInput, RawTarget)]) +parseRawTargetDirs root locals ri = + case parseRawTarget t of + Just rt -> return $ Right [(ri, rt)] + Nothing -> do + mdir <- liftIO $ forgivingAbsence (resolveDir root (T.unpack t)) + >>= rejectMissingDir + case mdir of + Nothing -> return $ Left $ "Directory not found: " `T.append` t + Just dir -> + case mapMaybe (childOf dir) $ Map.toList locals of + [] -> return $ Left $ + "No local directories found as children of " `T.append` + t + names -> return $ Right $ map ((ri, ) . RTPackage) names + where + childOf dir (name, lpv) = + if dir == lpvRoot lpv || isProperPrefixOf dir (lpvRoot lpv) + then Just name + else Nothing -data RawTargetType = HasIdents | NoIdents + RawInput t = ri -- | If this function returns @Nothing@, the input should be treated as a -- directory. -parseRawTarget :: Text -> Maybe (RawTarget 'HasIdents) +parseRawTarget :: Text -> Maybe RawTarget parseRawTarget t = - (RTPackageIdentifier <$> parsePackageIdentifierFromString s) + (RTPackageIdentifier <$> parsePackageIdentifier t) <|> (RTPackage <$> parsePackageNameFromString s) <|> (RTComponent <$> T.stripPrefix ":" t) <|> parsePackageComponent @@ -104,94 +200,75 @@ "bench" -> Just CBench _ -> Nothing --- | A view of a local package needed for resolving components -data LocalPackageView = LocalPackageView - { lpvVersion :: !Version - , lpvRoot :: !(Path Abs Dir) - , lpvCabalFP :: !(Path Abs File) - , lpvComponents :: !(Set NamedComponent) - , lpvExtraDep :: !TreatLikeExtraDep - } - --- | Same as @parseRawTarget@, but also takes directories into account. -parseRawTargetDirs :: (MonadIO m, MonadCatch m) - => Path Abs Dir -- ^ current directory - -> Map PackageName LocalPackageView - -> Text - -> m (Either Text [(RawInput, RawTarget 'HasIdents)]) -parseRawTargetDirs root locals t = - case parseRawTarget t of - Just rt -> return $ Right [(ri, rt)] - Nothing -> do - mdir <- forgivingAbsence (resolveDir root (T.unpack t)) - >>= rejectMissingDir - case mdir of - Nothing -> return $ Left $ "Directory not found: " `T.append` t - Just dir -> - case mapMaybe (childOf dir) $ Map.toList locals of - [] -> return $ Left $ - "No local directories found as children of " `T.append` - t - names -> return $ Right $ map ((ri, ) . RTPackage) names - where - ri = RawInput t - - childOf dir (name, lpv) = - if (dir == lpvRoot lpv || isParentOf dir (lpvRoot lpv)) && not (lpvExtraDep lpv) - then Just name - else Nothing - -data SimpleTarget - = STUnknown - | STNonLocal - | STLocalComps !(Set NamedComponent) - | STLocalAll - deriving (Show, Eq, Ord) +--------------------------------------------------------------------------------- +-- Resolve the raw targets +--------------------------------------------------------------------------------- -resolveIdents :: Map PackageName Version -- ^ snapshot - -> Map PackageName Version -- ^ extra deps - -> Map PackageName LocalPackageView - -> (RawInput, RawTarget 'HasIdents) - -> 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 snap extras locals (ri, RTPackageIdentifier (PackageIdentifier name version)) = - fmap ((ri, RTPackage name), ) newExtras - where - newExtras = - case (Map.lookup name locals, mfound) of - -- Error if it matches a local package, pkg idents not - -- supported for local. - (Just _, _) -> Left $ T.concat - [ packageNameText name - , " target has a specific version number, but it is a local package." - , "\nTo avoid confusion, we will not install the specified version or build the local one." - , "\nTo build the local package, specify the target without an explicit version." - ] - -- If the found version matches, no need for an extra-dep. - (_, Just foundVersion) | foundVersion == version -> Right Map.empty - -- Otherwise, if there is no specified version or a - -- mismatch, add an extra-dep. - _ -> Right $ Map.singleton name version - mfound = asum (map (Map.lookup name) [extras, snap]) +data ResolveResult = ResolveResult + { rrName :: !PackageName + , rrRaw :: !RawInput + , rrComponent :: !(Maybe NamedComponent) + -- ^ Was a concrete component specified? + , rrAddedDep :: !(Maybe Version) + -- ^ Only if we're adding this as a dependency + , rrPackageType :: !PackageType + } -resolveRawTarget :: Map PackageName Version -- ^ snapshot - -> Map PackageName Version -- ^ extra deps - -> Map PackageName LocalPackageView - -> (RawInput, RawTarget 'NoIdents) - -> Either Text (PackageName, (RawInput, SimpleTarget)) -resolveRawTarget snap extras locals (ri, rt) = +-- | Convert a 'RawTarget' into a 'ResolveResult' (see description on +-- the module). +resolveRawTarget + :: forall env. HasConfig env + => Map PackageName (LoadedPackageInfo GhcPkgId) -- ^ globals + -> Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) -- ^ snapshot + -> Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath) -- ^ local deps + -> Map PackageName LocalPackageView -- ^ project packages + -> (RawInput, RawTarget) + -> RIO env (Either Text ResolveResult) +resolveRawTarget globals snap deps locals (ri, rt) = go rt where - go (RTPackageComponent name ucomp) = + -- Helper function: check if a 'NamedComponent' matches the given 'ComponentName' + isCompNamed :: ComponentName -> NamedComponent -> Bool + isCompNamed _ CLib = False + isCompNamed t1 (CExe t2) = t1 == t2 + isCompNamed t1 (CTest t2) = t1 == t2 + isCompNamed t1 (CBench t2) = t1 == t2 + + go (RTComponent cname) = return $ + -- Associated list from component name to package that defines + -- it. We use an assoc list and not a Map so we can detect + -- duplicates. + let allPairs = concatMap + (\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv) + (Map.toList locals) + in case filter (isCompNamed cname . snd) allPairs of + [] -> Left $ cname `T.append` " doesn't seem to be a local target. Run 'stack ide targets' for a list of available targets" + [(name, comp)] -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Just comp + , rrAddedDep = Nothing + , rrPackageType = ProjectPackage + } + matches -> Left $ T.concat + [ "Ambiugous component name " + , cname + , ", matches: " + , T.pack $ show matches + ] + go (RTPackageComponent name ucomp) = return $ case Map.lookup name locals of Nothing -> Left $ T.pack $ "Unknown local package: " ++ packageNameString name Just lpv -> case ucomp of ResolvedComponent comp - | comp `Set.member` lpvComponents lpv -> - Right (name, (ri, STLocalComps $ Set.singleton comp)) + | comp `Set.member` lpvComponents lpv -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Just comp + , rrAddedDep = Nothing + , rrPackageType = ProjectPackage + } | otherwise -> Left $ T.pack $ concat [ "Component " , show comp @@ -206,7 +283,13 @@ , " does not exist in package " , T.pack $ packageNameString name ] - [x] -> Right (name, (ri, STLocalComps $ Set.singleton x)) + [x] -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Just x + , rrAddedDep = Nothing + , rrPackageType = ProjectPackage + } matches -> Left $ T.concat [ "Ambiguous component name " , comp @@ -215,109 +298,260 @@ , ": " , T.pack $ show matches ] - go (RTComponent cname) = - let allPairs = concatMap - (\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv) - (Map.toList locals) - in case filter (isCompNamed cname . snd) allPairs of - [] -> Left $ cname `T.append` " doesn't seem to be a local target. Run 'stack ide targets' for a list of available targets" - [(name, comp)] -> - Right (name, (ri, STLocalComps $ Set.singleton comp)) - matches -> Left $ T.concat - [ "Ambiugous component name " - , cname - , ", matches: " - , T.pack $ show matches - ] - go (RTPackage name) = - case Map.lookup name locals of - Just _lpv -> Right (name, (ri, STLocalAll)) - Nothing -> - case Map.lookup name extras of - Just _ -> Right (name, (ri, STNonLocal)) - Nothing -> - case Map.lookup name snap of - Just _ -> Right (name, (ri, STNonLocal)) - Nothing -> Right (name, (ri, STUnknown)) + go (RTPackage name) + | Map.member name locals = return $ Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = Nothing + , rrPackageType = ProjectPackage + } + | Map.member name deps || + Map.member name snap || + Map.member name globals = return $ Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = Nothing + , rrPackageType = Dependency + } + | otherwise = do + mversion <- getLatestVersion name + return $ case mversion of + -- This is actually an error case. We _could_ return a + -- Left value here, but it turns out to be better to defer + -- this until the ConstructPlan phase, and let it complain + -- about the missing package so that we get more errors + -- together, plus the fancy colored output from that + -- module. + Nothing -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = Nothing + , rrPackageType = Dependency + } + Just version -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = Just version + , rrPackageType = Dependency + } + where + getLatestVersion pn = do + vs <- getPackageVersions pn + return (fmap fst (Set.maxView vs)) -isCompNamed :: Text -> NamedComponent -> Bool -isCompNamed _ CLib = False -isCompNamed t1 (CExe t2) = t1 == t2 -isCompNamed t1 (CTest t2) = t1 == t2 -isCompNamed t1 (CBench t2) = t1 == t2 + go (RTPackageIdentifier ident@(PackageIdentifier name version)) + | Map.member name locals = return $ Left $ T.concat + [ packageNameText name + , " target has a specific version number, but it is a local package." + , "\nTo avoid confusion, we will not install the specified version or build the local one." + , "\nTo build the local package, specify the target without an explicit version." + ] + | otherwise = return $ + case Map.lookup name allLocs of + -- Installing it from the package index, so we're cool + -- with overriding it if necessary + Just (PLIndex (PackageIdentifierRevision (PackageIdentifier _name versionLoc) _mcfi)) -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = + if version == versionLoc + -- But no need to override anyway, this is already the + -- version we have + then Nothing + -- OK, we'll override it + else Just version + , rrPackageType = Dependency + } + -- The package was coming from something besides the + -- index, so refuse to do the override + Just (PLOther loc') -> Left $ T.concat + [ "Package with identifier was targeted on the command line: " + , packageIdentifierText ident + , ", but it was specified from a non-index location: " + , T.pack $ show loc' + , ".\nRecommendation: add the correctly desired version to extra-deps." + ] + -- Not present at all, so add it + Nothing -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = Just version + , rrPackageType = Dependency + } -simplifyTargets :: [(PackageName, (RawInput, SimpleTarget))] - -> ([Text], Map PackageName SimpleTarget) -simplifyTargets = - foldMap go . collect - where - go :: (PackageName, NonEmpty (RawInput, SimpleTarget)) - -> ([Text], Map PackageName SimpleTarget) - go (name, (_, st) :| []) = ([], Map.singleton name st) - go (name, pairs) = - case partitionEithers $ map (getLocalComp . snd) (NonEmpty.toList pairs) of - ([], comps) -> ([], Map.singleton name $ STLocalComps $ Set.unions comps) - _ -> - let err = T.pack $ concat - [ "Overlapping targets provided for package " - , packageNameString name - , ": " - , show $ map (unRawInput . fst) (NonEmpty.toList pairs) - ] - in ([err], Map.empty) + where + allLocs :: Map PackageName (PackageLocationIndex FilePath) + allLocs = Map.unions + [ Map.mapWithKey + (\name' lpi -> PLIndex $ PackageIdentifierRevision + (PackageIdentifier name' (lpiVersion lpi)) + CFILatest) + globals + , Map.map lpiLocation snap + , Map.map snd deps + ] - collect :: Ord a => [(a, b)] -> [(a, NonEmpty b)] - collect = map (second NonEmpty.fromList) . groupSort +--------------------------------------------------------------------------------- +-- Combine the ResolveResults +--------------------------------------------------------------------------------- - getLocalComp (STLocalComps comps) = Right comps - getLocalComp _ = Left () +-- | How a package is intended to be built +data Target + = TargetAll !PackageType + -- ^ Build all of the default components. + | TargetComps !(Set NamedComponent) + -- ^ Only build specific components --- | Need targets, e.g. `stack build` or allow none? -data NeedTargets - = NeedTargets - | AllowNoTargets +data PackageType = ProjectPackage | Dependency + deriving (Eq, Show) -parseTargets :: (MonadCatch m, MonadIO m) - => NeedTargets -- ^ need at least one target - -> Bool -- ^ using implicit global project? - -> Map PackageName Version -- ^ snapshot - -> Map PackageName Version -- ^ extra deps - -> Map PackageName LocalPackageView - -> Path Abs Dir -- ^ current directory - -> [Text] -- ^ command line targets - -> m (Map PackageName Version, Map PackageName SimpleTarget) -parseTargets needTargets implicitGlobal snap extras locals currDir textTargets' = do - let nonExtraDeps = Map.keys $ Map.filter (not . lpvExtraDep) locals - textTargets = - if null textTargets' - then map (T.pack . packageNameString) nonExtraDeps - else textTargets' - erawTargets <- mapM (parseRawTargetDirs currDir locals) textTargets +combineResolveResults + :: forall m. MonadLogger m + => [ResolveResult] + -> m ([Text], Map PackageName Target, Map PackageName (PackageLocationIndex FilePath)) +combineResolveResults results = do + addedDeps <- fmap Map.unions $ forM results $ \result -> + case rrAddedDep result of + Nothing -> return Map.empty + Just version -> do + let ident = PackageIdentifier (rrName result) version + return $ Map.singleton (rrName result) $ PLIndex $ PackageIdentifierRevision ident CFILatest - let (errs1, rawTargets) = partitionEithers erawTargets - -- When specific package identifiers are provided, treat these - -- as extra-deps. - (errs2, unzip -> (rawTargets', newExtras)) = partitionEithers $ - map (resolveIdents snap extras locals) $ concat rawTargets - -- Find targets that specify components in the local packages, - -- otherwise find package targets in snap and extra-deps. - (errs3, targetTypes) = partitionEithers $ - map (resolveRawTarget snap extras locals) rawTargets' - (errs4, targets) = simplifyTargets targetTypes - errs = concat [errs1, errs2, errs3, errs4] + let m0 = Map.unionsWith (++) $ map (\rr -> Map.singleton (rrName rr) [rr]) results + (errs, ms) = partitionEithers $ flip map (Map.toList m0) $ \(name, rrs) -> + let mcomps = map rrComponent rrs in + -- Confirm that there is either exactly 1 with no component, or + -- that all rrs are components + case rrs of + [] -> assert False $ Left "Somehow got no rrComponent values, that can't happen" + [rr] | isNothing (rrComponent rr) -> Right $ Map.singleton name $ TargetAll $ rrPackageType rr + _ + | all isJust mcomps -> Right $ Map.singleton name $ TargetComps $ Set.fromList $ catMaybes mcomps + | otherwise -> Left $ T.concat + [ "The package " + , packageNameText name + , " was specified in multiple, incompatible ways: " + , T.unwords $ map (unRawInput . rrRaw) rrs + ] - if null errs - then if Map.null targets - then case needTargets of - AllowNoTargets -> - return (Map.empty, Map.empty) - NeedTargets - | null textTargets' && implicitGlobal -> throwM $ TargetParseException - ["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"] - | null textTargets' && null nonExtraDeps -> throwM $ TargetParseException - ["The project contains no local packages (packages not marked with 'extra-dep')"] - | otherwise -> throwM $ TargetParseException - ["The specified targets matched no packages"] - else return (Map.unions newExtras, targets) - else throwM $ TargetParseException errs + return (errs, Map.unions ms, addedDeps) + +--------------------------------------------------------------------------------- +-- OK, let's do it! +--------------------------------------------------------------------------------- + +parseTargets + :: HasEnvConfig env + => NeedTargets + -> BuildOptsCLI + -> RIO env + ( LoadedSnapshot -- upgraded snapshot, with some packages possibly moved to local + , Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) -- all local deps + , Map PackageName Target + ) +parseTargets needTargets boptscli = do + logDebug "Parsing the targets" + bconfig <- view buildConfigL + ls0 <- view loadedSnapshotL + workingDir <- getCurrentDir + lp <- getLocalPackages + let locals = lpProject lp + deps = lpDependencies lp + globals = lsGlobals ls0 + snap = lsPackages ls0 + (textTargets', rawInput) = getRawInput boptscli locals + + (errs1, concat -> rawTargets) <- fmap partitionEithers $ forM rawInput $ + parseRawTargetDirs workingDir (lpProject lp) + + (errs2, resolveResults) <- fmap partitionEithers $ forM rawTargets $ + resolveRawTarget globals snap deps locals + + (errs3, targets, addedDeps) <- combineResolveResults resolveResults + + case concat [errs1, errs2, errs3] of + [] -> return () + errs -> throwIO $ TargetParseException errs + + case (Map.null targets, needTargets) of + (False, _) -> return () + (True, AllowNoTargets) -> return () + (True, NeedTargets) + | null textTargets' && bcImplicitGlobal bconfig -> throwIO $ TargetParseException + ["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"] + | null textTargets' && Map.null locals -> throwIO $ TargetParseException + ["The project contains no local packages (packages not marked with 'extra-dep')"] + | otherwise -> throwIO $ TargetParseException + ["The specified targets matched no packages"] + + root <- view projectRootL + + let dropMaybeKey (Nothing, _) = Map.empty + dropMaybeKey (Just key, value) = Map.singleton key value + flags = Map.unionWith Map.union + (Map.unions (map dropMaybeKey (Map.toList (boptsCLIFlags boptscli)))) + (bcFlags bconfig) + hides = Map.empty -- not supported to add hidden packages + + -- We promote packages to the local database if the GHC options + -- are added to them by name. See: + -- https://github.com/commercialhaskell/stack/issues/849#issuecomment-320892095. + -- + -- GHC options applied to all packages are handled by getGhcOptions. + options = configGhcOptionsByName (bcConfig bconfig) + + drops = Set.empty -- not supported to add drops + + (globals', snapshots, locals') <- withCabalLoader $ \loadFromIndex -> do + addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do + gpd <- parseSingleCabalFileIndex loadFromIndex root loc + return (name, (gpd, loc, Nothing)) + + -- Calculate a list of all of the locals, based on the project + -- packages, local dependencies, and added deps found from the + -- command line + let allLocals :: Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath, Maybe LocalPackageView) + allLocals = Map.unions + [ -- project packages + Map.map + (\lpv -> (lpvGPD lpv, PLOther $ lpvLoc lpv, Just lpv)) + (lpProject lp) + , -- added deps take precendence over local deps + addedDeps' + , -- added deps take precendence over local deps + Map.map + (\(gpd, loc) -> (gpd, loc, Nothing)) + (lpDependencies lp) + ] + + calculatePackagePromotion + loadFromIndex root ls0 (Map.elems allLocals) + flags hides options drops + + let ls = LoadedSnapshot + { lsCompilerVersion = lsCompilerVersion ls0 + , lsGlobals = globals' + , lsPackages = snapshots + } + + localDeps = Map.fromList $ flip mapMaybe (Map.toList locals') $ \(name, lpi) -> + -- We want to ignore any project packages, but grab the local + -- deps and upgraded snapshot deps + case lpiLocation lpi of + (_, Just (Just _localPackageView)) -> Nothing -- project package + (loc, _) -> Just (name, lpi { lpiLocation = loc }) -- upgraded or local dep + + return (ls, localDeps, targets) + +gpdVersion :: GenericPackageDescription -> Version +gpdVersion gpd = + version + where + PackageIdentifier _ version = fromCabalPackageIdentifier $ package $ packageDescription gpd diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -1,12 +1,11 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Resolving a build plan for a set of packages in a given Stackage -- snapshot. @@ -19,84 +18,42 @@ , DepErrors , gpdPackageDeps , gpdPackages - , gpdPackageName - , MiniBuildPlan(..) - , MiniPackageInfo(..) - , loadResolver - , loadMiniBuildPlan , removeSrcPkgDefaultFlags - , resolveBuildPlan , selectBestSnapshot , getToolMap - , shadowMiniBuildPlan , showItems - , showPackageFlags - , parseCustomMiniBuildPlan - , loadBuildPlan ) where -import Control.Applicative -import Control.Exception (assert) -import Control.Monad (liftM, forM, unless) -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Reader (MonadReader) -import Control.Monad.State.Strict (State, execState, get, modify, - put) -import Crypto.Hash (hashWith, SHA256(..)) -import Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings) -import Data.Store.VersionTagged -import qualified Data.ByteArray as Mem (convert) -import qualified Data.ByteString as S -import qualified Data.ByteString.Base64.URL as B64URL -import qualified Data.ByteString.Char8 as S8 -import Data.Either (partitionEithers) +import Stack.Prelude import qualified Data.Foldable as F import qualified Data.HashSet as HashSet import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty -import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, mapMaybe, isNothing) -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Traversable as Tr -import Data.Typeable (Typeable) -import Data.Yaml (decodeEither', decodeFileEither) import qualified Distribution.Package as C import Distribution.PackageDescription (GenericPackageDescription, flagDefault, flagManual, flagName, genPackageFlags, - executables, exeName, library, libBuildInfo, buildable) + condExecutables) import qualified Distribution.PackageDescription as C +import qualified Distribution.Types.UnqualComponentName as C import Distribution.System (Platform) import Distribution.Text (display) import qualified Distribution.Version as C -import Network.HTTP.Download -import Path -import Path.IO -import Prelude -- Fix AMP warning import Stack.Constants -import Stack.Fetch import Stack.Package -import Stack.PackageIndex +import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.FlagName import Stack.Types.PackageIdentifier -import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.Version import Stack.Types.Config -import Stack.Types.Urls import Stack.Types.Compiler import Stack.Types.Resolver -import Stack.Types.StackT data BuildPlanException = UnknownPackages @@ -104,7 +61,6 @@ (Map PackageName (Maybe Version, Set PackageName)) -- truly unknown (Map PackageName (Set PackageIdentifier)) -- shadowed | SnapshotNotFound SnapName - | FilepathInDownloadedSnapshot T.Text | NeitherCompilerOrResolverSpecified T.Text deriving (Typeable) instance Exception BuildPlanException @@ -182,246 +138,17 @@ $ Set.toList $ Set.unions $ Map.elems shadowed - show (FilepathInDownloadedSnapshot url) = unlines - [ "Downloaded snapshot specified a 'resolver: { location: filepath }' " - , "field, but filepaths are not allowed in downloaded snapshots.\n" - , "Filepath specified: " ++ T.unpack url - ] show (NeitherCompilerOrResolverSpecified url) = "Failed to load custom snapshot at " ++ T.unpack url ++ ", because no 'compiler' or 'resolver' is specified." --- | Determine the necessary packages to install to have the given set of --- packages available. --- --- This function will not provide test suite and benchmark dependencies. --- --- This may fail if a target package is not present in the @BuildPlan@. -resolveBuildPlan - :: (StackMiniM env m, HasBuildConfig env) - => MiniBuildPlan - -> (PackageName -> Bool) -- ^ is it shadowed by a local package? - -> Map PackageName (Set PackageName) -- ^ required packages, and users of it - -> m ( Map PackageName (Version, Map FlagName Bool) - , Map PackageName (Set PackageName) - ) -resolveBuildPlan mbp isShadowed packages - | Map.null (rsUnknown rs) && Map.null (rsShadowed rs) = return (rsToInstall rs, rsUsedBy rs) - | otherwise = do - bconfig <- view buildConfigL - (caches, _gitShaCaches) <- getPackageCaches - let maxVer = - Map.fromListWith max $ - map toTuple $ - Map.keys caches - unknown = flip Map.mapWithKey (rsUnknown rs) $ \ident x -> - (Map.lookup ident maxVer, x) - throwM $ UnknownPackages - (bcStackYaml bconfig) - unknown - (rsShadowed rs) - where - rs = getDeps mbp isShadowed packages - -data ResolveState = ResolveState - { rsVisited :: Map PackageName (Set PackageName) -- ^ set of shadowed dependencies - , rsUnknown :: Map PackageName (Set PackageName) - , rsShadowed :: Map PackageName (Set PackageIdentifier) - , rsToInstall :: Map PackageName (Version, Map FlagName Bool) - , rsUsedBy :: Map PackageName (Set PackageName) - } - -toMiniBuildPlan - :: (StackMiniM env m, HasConfig env) - => CompilerVersion -- ^ Compiler version - -> Map PackageName Version -- ^ cores - -> Map PackageName (Version, Map FlagName Bool, [Text], Maybe GitSHA1) -- ^ non-core packages - -> m MiniBuildPlan -toMiniBuildPlan compilerVersion corePackages packages = do - -- Determine the dependencies of all of the packages in the build plan. We - -- handle core packages specially, because some of them will not be in the - -- package index. For those, we allow missing packages to exist, and then - -- remove those from the list of dependencies, since there's no way we'll - -- ever reinstall them anyway. - (cores, missingCores) <- addDeps True compilerVersion - $ fmap (, Map.empty, [], Nothing) corePackages - - (extras, missing) <- addDeps False compilerVersion packages - - assert (Set.null missing) $ return MiniBuildPlan - { mbpCompilerVersion = compilerVersion - , mbpPackages = Map.unions - [ fmap (removeMissingDeps (Map.keysSet cores)) cores - , extras - , Map.fromList $ map goCore $ Set.toList missingCores - ] - } - where - goCore (PackageIdentifier name version) = (name, MiniPackageInfo - { mpiVersion = version - , mpiFlags = Map.empty - , mpiGhcOptions = [] - , mpiPackageDeps = Set.empty - , mpiToolDeps = Set.empty - , mpiExes = Set.empty - , mpiHasLibrary = True - , mpiGitSHA1 = Nothing - }) - - removeMissingDeps cores mpi = mpi - { mpiPackageDeps = Set.intersection cores (mpiPackageDeps mpi) - } - --- | Add in the resolved dependencies from the package index -addDeps - :: (StackMiniM env m, HasConfig env) - => Bool -- ^ allow missing - -> CompilerVersion -- ^ Compiler version - -> Map PackageName (Version, Map FlagName Bool, [Text], Maybe GitSHA1) - -> m (Map PackageName MiniPackageInfo, Set PackageIdentifier) -addDeps allowMissing compilerVersion toCalc = do - platform <- view platformL - (resolvedMap, missingIdents) <- - if allowMissing - then do - (missingNames, missingIdents, m) <- - resolvePackagesAllowMissing Nothing shaMap Set.empty - assert (Set.null missingNames) - $ return (m, missingIdents) - else do - m <- resolvePackages Nothing shaMap Set.empty - return (m, Set.empty) - let byIndex = Map.fromListWith (++) $ flip map resolvedMap - $ \rp -> - let (cache, ghcOptions, sha) = - case Map.lookup (packageIdentifierName (rpIdent rp)) toCalc of - Nothing -> (Map.empty, [], Nothing) - Just (_, x, y, z) -> (x, y, z) - in (indexName $ rpIndex rp, [(rp, (cache, ghcOptions, sha))]) - res <- forM (Map.toList byIndex) $ \(indexName', pkgs) -> - fmap Map.unions $ withCabalFiles indexName' pkgs - $ \ident (flags, ghcOptions, mgitSha) cabalBS -> - case readPackageUnresolvedBS (Right ident) cabalBS of - Left e - | allowedToSkip ident -> return Map.empty - | otherwise -> throwM e - Right (_warnings, gpd) -> do - let packageConfig = PackageConfig - { packageConfigEnableTests = False - , packageConfigEnableBenchmarks = False - , packageConfigFlags = flags - , packageConfigGhcOptions = ghcOptions - , packageConfigCompilerVersion = compilerVersion - , packageConfigPlatform = platform - } - name = packageIdentifierName ident - pd = resolvePackageDescription packageConfig gpd - exes = Set.fromList $ map (ExeName . T.pack . exeName) $ executables pd - notMe = Set.filter (/= name) . Map.keysSet - return $ Map.singleton name MiniPackageInfo - { mpiVersion = packageIdentifierVersion ident - , mpiFlags = flags - , mpiGhcOptions = ghcOptions - , mpiPackageDeps = notMe $ packageDependencies pd - , mpiToolDeps = Map.keysSet $ packageToolDependencies pd - , mpiExes = exes - , mpiHasLibrary = maybe - False - (buildable . libBuildInfo) - (library pd) - , mpiGitSHA1 = mgitSha - } - return (Map.unions res, missingIdents) - where - shaMap = Map.fromList - $ map (\(n, (v, _f, _ghcOptions, gitsha)) -> (PackageIdentifier n v, gitsha)) - $ Map.toList toCalc - - -- Michael Snoyman, 2017-07-31: - -- - -- This is a stop-gap measure to address a specific concern around - -- the GHC 8.2.1 release. The current Stack version (1.5.0) will - -- eagerly parse all cabal files mentioned in a snapshot, - -- including global packages. Additionally, for the first time - -- (AFAICT), GHC 8.2.1 is providing a package on Hackage with a - -- ghc.cabal file, which requires the (not yet supported) Cabal - -- 2.0 file format. To work around this, we're adding a special - -- dispensation to ignore parse failures for this package. - -- - -- Master already does better by simply ignoring global - -- information and looking things up in the database. We may want - -- to consider going a step further and simply ignoring _all_ - -- parse failures, or turning them into warnings, though I haven't - -- considered the repercussions of that. - allowedToSkip (PackageIdentifier name _) = name == $(mkPackageName "ghc") - --- | Resolve all packages necessary to install for the needed packages. -getDeps :: MiniBuildPlan - -> (PackageName -> Bool) -- ^ is it shadowed by a local package? - -> Map PackageName (Set PackageName) - -> ResolveState -getDeps mbp isShadowed packages = - execState (mapM_ (uncurry goName) $ Map.toList packages) ResolveState - { rsVisited = Map.empty - , rsUnknown = Map.empty - , rsShadowed = Map.empty - , rsToInstall = Map.empty - , rsUsedBy = Map.empty - } - where - toolMap = getToolMap mbp - - -- | Returns a set of shadowed packages we depend on. - goName :: PackageName -> Set PackageName -> State ResolveState (Set PackageName) - goName name users = do - -- Even though we could check rsVisited first and short-circuit things - -- earlier, lookup in mbpPackages first so that we can produce more - -- usable error information on missing dependencies - rs <- get - put rs - { rsUsedBy = Map.insertWith Set.union name users $ rsUsedBy rs - } - case Map.lookup name $ mbpPackages mbp of - Nothing -> do - modify $ \rs' -> rs' - { rsUnknown = Map.insertWith Set.union name users $ rsUnknown rs' - } - return Set.empty - Just mpi -> case Map.lookup name (rsVisited rs) of - Just shadowed -> return shadowed - Nothing -> do - put rs { rsVisited = Map.insert name Set.empty $ rsVisited rs } - let depsForTools = Set.unions $ mapMaybe (flip Map.lookup toolMap) (Set.toList $ mpiToolDeps mpi) - let deps = Set.filter (/= name) (mpiPackageDeps mpi <> depsForTools) - shadowed <- fmap F.fold $ Tr.forM (Set.toList deps) $ \dep -> - if isShadowed dep - then do - modify $ \rs' -> rs' - { rsShadowed = Map.insertWith - Set.union - dep - (Set.singleton $ PackageIdentifier name (mpiVersion mpi)) - (rsShadowed rs') - } - return $ Set.singleton dep - else do - shadowed <- goName dep (Set.singleton name) - let m = Map.fromSet (\_ -> Set.singleton $ PackageIdentifier name (mpiVersion mpi)) shadowed - modify $ \rs' -> rs' - { rsShadowed = Map.unionWith Set.union m $ rsShadowed rs' - } - return shadowed - modify $ \rs' -> rs' - { rsToInstall = Map.insert name (mpiVersion mpi, mpiFlags mpi) $ rsToInstall rs' - , rsVisited = Map.insert name shadowed $ rsVisited rs' - } - return shadowed - --- | Map from tool name to package providing it -getToolMap :: MiniBuildPlan -> Map Text (Set PackageName) -getToolMap mbp = - Map.unionsWith Set.union +-- | Map from tool name to package providing it. This accounts for +-- both snapshot and local packages (deps and project packages). +getToolMap :: LoadedSnapshot + -> LocalPackages + -> Map ExeName (Set PackageName) +getToolMap ls locals = {- We no longer do this, following discussion at: @@ -432,111 +159,30 @@ $ Map.fromList (map (packageNameByteString &&& Set.singleton) (Map.keys ps)) -} - -- And then get all of the explicit executable names - $ concatMap goPair (Map.toList ps) + Map.unionsWith Set.union $ concat + [ concatMap goSnap $ Map.toList $ lsPackages ls + , concatMap goLocalProj $ Map.toList $ lpProject locals + , concatMap goLocalDep $ Map.toList $ lpDependencies locals + ] where - ps = mbpPackages mbp - - goPair (pname, mpi) = - map (flip Map.singleton (Set.singleton pname) . unExeName) + goSnap (pname, lpi) = + map (flip Map.singleton (Set.singleton pname)) $ Set.toList - $ mpiExes mpi - -loadResolver - :: (StackMiniM env m, HasConfig env, HasGHCVariant env) - => Maybe (Path Abs File) - -> Resolver - -> m (MiniBuildPlan, LoadedResolver) -loadResolver mconfigPath resolver = - case resolver of - ResolverSnapshot snap -> - liftM (, ResolverSnapshot snap) $ loadMiniBuildPlan snap - -- TODO(mgsloan): Not sure what this FIXME means - -- FIXME instead of passing the stackYaml dir we should maintain - -- the file URL in the custom resolver always relative to stackYaml. - ResolverCustom name url -> do - (mbp, hash) <- parseCustomMiniBuildPlan mconfigPath url - return (mbp, ResolverCustomLoaded name url hash) - ResolverCompiler compiler -> return - ( MiniBuildPlan - { mbpCompilerVersion = compiler - , mbpPackages = mempty - } - , ResolverCompiler compiler - ) - --- | Load up a 'MiniBuildPlan', preferably from cache -loadMiniBuildPlan - :: (StackMiniM env m, HasConfig env, HasGHCVariant env) - => SnapName -> m MiniBuildPlan -loadMiniBuildPlan name = do - path <- configMiniBuildPlanCache name - $(versionedDecodeOrLoad miniBuildPlanVC) path $ liftM buildPlanFixes $ do - bp <- loadBuildPlan name - toMiniBuildPlan - (siCompilerVersion $ bpSystemInfo bp) - (siCorePackages $ bpSystemInfo bp) - (goPP <$> bpPackages bp) - where - goPP pp = - ( ppVersion pp - , pcFlagOverrides $ ppConstraints pp - -- TODO: store ghc options in BuildPlan? - , [] - , ppCabalFileInfo pp - >>= fmap (GitSHA1 . encodeUtf8) - . Map.lookup "GitSHA1" - . cfiHashes - ) - --- | Some hard-coded fixes for build plans, hopefully to be irrelevant over --- time. -buildPlanFixes :: MiniBuildPlan -> MiniBuildPlan -buildPlanFixes mbp = mbp - { mbpPackages = Map.fromList $ map go $ Map.toList $ mbpPackages mbp - } - where - go (name, mpi) = - (name, mpi - { mpiFlags = goF (packageNameString name) (mpiFlags mpi) - }) - - goF "persistent-sqlite" = Map.insert $(mkFlagName "systemlib") False - goF "yaml" = Map.insert $(mkFlagName "system-libyaml") False - goF _ = id + $ lpiProvidedExes lpi --- | Load the 'BuildPlan' for the given snapshot. Will load from a local copy --- if available, otherwise downloading from Github. -loadBuildPlan :: (StackMiniM env m, HasConfig env) => SnapName -> m BuildPlan -loadBuildPlan name = do - stackage <- view stackRootL - file' <- parseRelFile $ T.unpack file - let fp = buildPlanDir stackage file' - $logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp) - eres <- liftIO $ decodeFileEither $ toFilePath fp - case eres of - Right bp -> return bp - Left e -> do - $logDebug $ "Decoding build plan from file failed: " <> T.pack (show e) - ensureDir (parent fp) - url <- buildBuildPlanUrl name file - req <- parseRequest $ T.unpack url - $logSticky $ "Downloading " <> renderSnapName name <> " build plan ..." - $logDebug $ "Downloading build plan from: " <> url - _ <- redownload req fp - $logStickyDone $ "Downloaded " <> renderSnapName name <> " build plan." - liftIO (decodeFileEither $ toFilePath fp) >>= either throwM return + goLocalProj (pname, lpv) = + map (flip Map.singleton (Set.singleton pname)) + [ExeName t | CExe t <- Set.toList (lpvComponents lpv)] - where - file = renderSnapName name <> ".yaml" + goLocalDep (pname, (gpd, _loc)) = + map (flip Map.singleton (Set.singleton pname)) + $ gpdExes gpd -buildBuildPlanUrl :: (MonadReader env m, HasConfig env) => SnapName -> Text -> m Text -buildBuildPlanUrl name file = do - urls <- view $ configL.to configUrls - return $ - case name of - LTS _ _ -> urlsLtsBuildPlans urls <> "/" <> file - Nightly _ -> urlsNightlyBuildPlans urls <> "/" <> file + -- TODO consider doing buildable checking. Not a big deal though: + -- worse case scenario is we build an extra package that wasn't + -- strictly needed. + gpdExes :: GenericPackageDescription -> [ExeName] + gpdExes = map (ExeName . T.pack . C.unUnqualComponentName . fst) . condExecutables gpdPackages :: [GenericPackageDescription] -> Map PackageName Version gpdPackages gpds = Map.fromList $ @@ -545,15 +191,9 @@ fromCabalIdent (C.PackageIdentifier name version) = (fromCabalPackageName name, fromCabalVersion version) -gpdPackageName :: GenericPackageDescription -> PackageName -gpdPackageName = fromCabalPackageName - . C.pkgName - . C.package - . C.packageDescription - gpdPackageDeps :: GenericPackageDescription - -> CompilerVersion + -> CompilerVersion 'CVActual -> Platform -> Map FlagName Bool -> Map PackageName VersionRange @@ -561,7 +201,9 @@ Map.filterWithKey (const . (/= name)) (packageDependencies pkgDesc) where name = gpdPackageName gpd - pkgDesc = resolvePackageDescription pkgConfig gpd + -- Since tests and benchmarks are both enabled, doesn't matter + -- if we choose modified or unmodified + pkgDesc = pdpModifiedBuildable $ resolvePackageDescription pkgConfig gpd pkgConfig = PackageConfig { packageConfigEnableTests = True , packageConfigEnableBenchmarks = True @@ -600,7 +242,7 @@ -- Returns the plan which produces least number of dep errors selectPackageBuildPlan :: Platform - -> CompilerVersion + -> CompilerVersion 'CVActual -> Map PackageName Version -> GenericPackageDescription -> (Map PackageName (Map FlagName Bool), DepErrors) @@ -639,7 +281,7 @@ -- constraints can be satisfied against a given build plan or pool of packages. checkPackageBuildPlan :: Platform - -> CompilerVersion + -> CompilerVersion 'CVActual -> Map PackageName Version -> Map FlagName Bool -> GenericPackageDescription @@ -693,7 +335,7 @@ -- will be chosen automatically. checkBundleBuildPlan :: Platform - -> CompilerVersion + -> CompilerVersion 'CVActual -> Map PackageName Version -> Maybe (Map PackageName (Map FlagName Bool)) -> [GenericPackageDescription] @@ -717,7 +359,7 @@ BuildPlanCheckOk (Map PackageName (Map FlagName Bool)) | BuildPlanCheckPartial (Map PackageName (Map FlagName Bool)) DepErrors | BuildPlanCheckFail (Map PackageName (Map FlagName Bool)) DepErrors - CompilerVersion + (CompilerVersion 'CVActual) -- | Compare 'BuildPlanCheck', where GT means a better plan. compareBuildPlanCheck :: BuildPlanCheck -> BuildPlanCheck -> Ordering @@ -742,18 +384,22 @@ -- given snapshot. Returns how well the snapshot satisfies the dependencies of -- the packages. checkSnapBuildPlan - :: (StackM env m, HasConfig env, HasGHCVariant env) - => [GenericPackageDescription] + :: (HasConfig env, HasGHCVariant env) + => Path Abs Dir -- ^ project root, used for checking out necessary files + -> [GenericPackageDescription] -> Maybe (Map PackageName (Map FlagName Bool)) - -> SnapName - -> m BuildPlanCheck -checkSnapBuildPlan gpds flags snap = do + -> SnapshotDef + -> Maybe (CompilerVersion 'CVActual) + -> RIO env BuildPlanCheck +checkSnapBuildPlan root gpds flags snapshotDef mactualCompiler = do platform <- view platformL - mbp <- loadMiniBuildPlan snap + rs <- loadSnapshot mactualCompiler root snapshotDef let - compiler = mbpCompilerVersion mbp - snapPkgs = mpiVersion <$> mbpPackages mbp + compiler = lsCompilerVersion rs + snapPkgs = Map.union + (lpiVersion <$> lsGlobals rs) + (lpiVersion <$> lsPackages rs) (f, errs) = checkBundleBuildPlan platform compiler snapPkgs flags gpds cerrs = compilerErrors compiler errs @@ -775,15 +421,16 @@ -- | Find a snapshot and set of flags that is compatible with and matches as -- best as possible with the given 'GenericPackageDescription's. selectBestSnapshot - :: (StackM env m, HasConfig env, HasGHCVariant env) - => [GenericPackageDescription] + :: (HasConfig env, HasGHCVariant env) + => Path Abs Dir -- ^ project root, used for checking out necessary files + -> [GenericPackageDescription] -> NonEmpty SnapName - -> m (SnapName, BuildPlanCheck) -selectBestSnapshot gpds snaps = do - $logInfo $ "Selecting the best among " + -> RIO env (SnapshotDef, BuildPlanCheck) +selectBestSnapshot root gpds snaps = do + logInfo $ "Selecting the best among " <> T.pack (show (NonEmpty.length snaps)) <> " snapshots...\n" - F.foldr1 go (NonEmpty.map getResult snaps) + F.foldr1 go (NonEmpty.map (getResult <=< loadResolver . ResolverSnapshot) snaps) where go mold mnew = do old@(_snap, bpc) <- mold @@ -792,7 +439,13 @@ _ -> fmap (betterSnap old) mnew getResult snap = do - result <- checkSnapBuildPlan gpds Nothing snap + result <- checkSnapBuildPlan root gpds Nothing snap + -- We know that we're only dealing with ResolverSnapshot + -- here, where we can rely on the global package hints. + -- Therefore, we don't use an actual compiler. For more + -- info, see comments on + -- Stack.Solver.checkSnapBuildPlanActual. + Nothing reportResult result snap return (snap, result) @@ -801,16 +454,16 @@ | otherwise = (s2, r2) reportResult BuildPlanCheckOk {} snap = do - $logInfo $ "* Matches " <> renderSnapName snap - $logInfo "" + logInfo $ "* Matches " <> sdResolverName snap + logInfo "" reportResult r@BuildPlanCheckPartial {} snap = do - $logWarn $ "* Partially matches " <> renderSnapName snap - $logWarn $ indent $ T.pack $ show r + logWarn $ "* Partially matches " <> sdResolverName snap + logWarn $ indent $ T.pack $ show r reportResult r@BuildPlanCheckFail {} snap = do - $logWarn $ "* Rejected " <> renderSnapName snap - $logWarn $ indent $ T.pack $ show r + logWarn $ "* Rejected " <> sdResolverName snap + logWarn $ indent $ T.pack $ show r indent t = T.unlines $ fmap (" " <>) (T.lines t) @@ -844,7 +497,7 @@ showCompilerErrors :: Map PackageName (Map FlagName Bool) -> DepErrors - -> CompilerVersion + -> CompilerVersion 'CVActual -> Text showCompilerErrors flags errs compiler = T.concat @@ -890,236 +543,3 @@ flagVals = T.concat (map showFlags userPkgs) userPkgs = Map.keys $ Map.unions (Map.elems (fmap deNeededBy errs)) showFlags pkg = maybe "" (showPackageFlags pkg) (Map.lookup pkg flags) - --- | Given a set of packages to shadow, this removes them, and any --- packages that transitively depend on them, from the 'MiniBuildPlan'. --- The 'Map' result yields all of the packages that were downstream of --- the shadowed packages. It does not include the shadowed packages. -shadowMiniBuildPlan :: MiniBuildPlan - -> Set PackageName - -> (MiniBuildPlan, Map PackageName MiniPackageInfo) -shadowMiniBuildPlan (MiniBuildPlan cv pkgs0) shadowed = - (MiniBuildPlan cv (Map.fromList met), Map.fromList unmet) - where - pkgs1 = Map.difference pkgs0 $ Map.fromSet (const ()) shadowed - - depsMet = flip execState Map.empty $ mapM_ (check Set.empty) (Map.keys pkgs1) - - check visited name - | name `Set.member` visited = - error $ "shadowMiniBuildPlan: cycle detected, your MiniBuildPlan is broken: " ++ show (visited, name) - | otherwise = do - m <- get - case Map.lookup name m of - Just x -> return x - Nothing -> - case Map.lookup name pkgs1 of - Nothing - | name `Set.member` shadowed -> return False - - -- In this case, we have to assume that we're - -- constructing a build plan on a different OS or - -- architecture, and therefore different packages - -- are being chosen. The common example of this is - -- the Win32 package. - | otherwise -> return True - Just mpi -> do - let visited' = Set.insert name visited - ress <- mapM (check visited') (Set.toList $ mpiPackageDeps mpi) - let res = and ress - modify $ \m' -> Map.insert name res m' - return res - - (met, unmet) = partitionEithers $ map toEither $ Map.toList pkgs1 - - toEither pair@(name, _) = - wrapper pair - where - wrapper = - case Map.lookup name depsMet of - Just True -> Left - Just False -> Right - Nothing -> assert False Right - --- This works differently for snapshots fetched from URL and those --- fetched from file: --- --- 1) If downloading the snapshot from a URL, assume the fetched data is --- immutable. Hash the URL in order to determine the location of the --- cached download. The file contents of the snapshot determines the --- hash for looking up cached MBP. --- --- 2) If loading the snapshot from a file, load all of the involved --- snapshot files. The hash used to determine the cached MBP is the hash --- of the concatenation of the parent's hash with the snapshot contents. --- --- Why this difference? We want to make it easy to simply edit snapshots --- in the filesystem, but we want caching for remote snapshots. In order --- to avoid reparsing / reloading all the yaml for remote snapshots, we --- need a different hash system. - --- TODO: This could probably be more efficient if it first merged the --- custom snapshots, and then applied them to the MBP. It is nice to --- apply directly, because then we have the guarantee that it's --- semantically identical to snapshot extension. If this optimization is --- implemented, note that the direct Monoid for CustomSnapshot is not --- correct. Crucially, if a package is present in the snapshot, its --- flags and ghc-options are not based on settings from prior snapshots. --- TODO: This semantics should be discussed / documented more. - --- TODO: allow a hash check in the resolver. This adds safety / --- correctness, allowing you to ensure that you are indeed getting the --- right custom snapshot. - --- TODO: Allow custom plan to specify a name. - -parseCustomMiniBuildPlan - :: (StackMiniM env m, HasConfig env, HasGHCVariant env) - => Maybe (Path Abs File) -- ^ Root directory for when url is a filepath - -> T.Text - -> m (MiniBuildPlan, SnapshotHash) -parseCustomMiniBuildPlan mconfigPath0 url0 = do - $logDebug $ "Loading " <> url0 <> " build plan" - case parseUrlThrow $ T.unpack url0 of - Just req -> downloadCustom url0 req - Nothing -> - case mconfigPath0 of - Nothing -> throwM $ FilepathInDownloadedSnapshot url0 - Just configPath -> do - (getMbp, hash) <- readCustom configPath url0 - mbp <- getMbp - -- NOTE: We make the choice of only writing a cache - -- file for the full MBP, not the intermediate ones. - -- This isn't necessarily the best choice if we want - -- to share work extended snapshots. I think only - -- writing this one is more efficient for common - -- cases. - binaryPath <- getBinaryPath hash - alreadyCached <- doesFileExist binaryPath - unless alreadyCached $ $(versionedEncodeFile miniBuildPlanVC) binaryPath mbp - return (mbp, hash) - where - downloadCustom url req = do - let urlHash = S8.unpack $ trimmedSnapshotHash $ doHash $ encodeUtf8 url - hashFP <- parseRelFile $ urlHash ++ ".yaml" - customPlanDir <- getCustomPlanDir - let cacheFP = customPlanDir $(mkRelDir "yaml") hashFP - _ <- download req cacheFP - yamlBS <- liftIO $ S.readFile $ toFilePath cacheFP - let yamlHash = doHash yamlBS - binaryPath <- getBinaryPath yamlHash - liftM (, yamlHash) $ $(versionedDecodeOrLoad miniBuildPlanVC) binaryPath $ do - (cs, mresolver) <- decodeYaml yamlBS - parentMbp <- case (csCompilerVersion cs, mresolver) of - (Nothing, Nothing) -> throwM (NeitherCompilerOrResolverSpecified url) - (Just cv, Nothing) -> return (compilerBuildPlan cv) - -- NOTE: ignoring the parent's hash, even though - -- there could be one. URL snapshot's hash are - -- determined just from their contents. - (_, Just resolver) -> liftM fst (loadResolver Nothing resolver) - applyCustomSnapshot cs parentMbp - readCustom configPath path = do - yamlFP <- resolveFile (parent configPath) (T.unpack $ fromMaybe path $ - T.stripPrefix "file://" path <|> T.stripPrefix "file:" path) - yamlBS <- liftIO $ S.readFile $ toFilePath yamlFP - (cs, mresolver) <- decodeYaml yamlBS - (getMbp, hash) <- case mresolver of - Just (ResolverCustom _ url ) -> - case parseUrlThrow $ T.unpack url of - Just req -> do - let getMbp = do - -- Ignore custom hash, under the - -- assumption that the URL is sufficient - -- for identity. - (mbp, _) <- downloadCustom url req - return mbp - return (getMbp, doHash yamlBS) - Nothing -> do - (getMbp0, SnapshotHash hash0) <- readCustom yamlFP url - let hash = doHash (hash0 <> yamlBS) - getMbp = do - binaryPath <- getBinaryPath hash - -- Idea here is to not waste time - -- writing out intermediate cache files, - -- but check for them. - exists <- doesFileExist binaryPath - if exists - then do - eres <- $(versionedDecodeFile miniBuildPlanVC) binaryPath - case eres of - Just mbp -> return mbp - -- Invalid format cache file, remove. - Nothing -> do - removeFile binaryPath - getMbp0 - else getMbp0 - return (getMbp, hash) - Just resolver -> do - -- NOTE: in the cases where we don't have a hash, the - -- normal resolver name is enough. Since this name is - -- part of the yaml file, it ends up in our hash. - let hash = doHash yamlBS - getMbp = do - (mbp, resolver') <- loadResolver (Just configPath) resolver - let mhash = customResolverHash resolver' - assert (isNothing mhash) (return mbp) - return (getMbp, hash) - Nothing -> do - case csCompilerVersion cs of - Nothing -> throwM (NeitherCompilerOrResolverSpecified path) - Just cv -> do - let hash = doHash yamlBS - getMbp = return (compilerBuildPlan cv) - return (getMbp, hash) - return (applyCustomSnapshot cs =<< getMbp, hash) - getBinaryPath hash = do - binaryFilename <- parseRelFile $ S8.unpack (trimmedSnapshotHash hash) ++ ".bin" - customPlanDir <- getCustomPlanDir - return $ customPlanDir $(mkRelDir "bin") binaryFilename - decodeYaml yamlBS = do - WithJSONWarnings res warnings <- - either (throwM . ParseCustomSnapshotException url0) return $ - decodeEither' yamlBS - logJSONWarnings (T.unpack url0) warnings - return res - compilerBuildPlan cv = MiniBuildPlan - { mbpCompilerVersion = cv - , mbpPackages = mempty - } - getCustomPlanDir = do - root <- view stackRootL - return $ root $(mkRelDir "custom-plan") - doHash = SnapshotHash . B64URL.encode . Mem.convert . hashWith SHA256 - -applyCustomSnapshot - :: (StackMiniM env m, HasConfig env) - => CustomSnapshot - -> MiniBuildPlan - -> m MiniBuildPlan -applyCustomSnapshot cs mbp0 = do - let CustomSnapshot mcompilerVersion - packages - dropPackages - (PackageFlags flags) - ghcOptions - = cs - addFlagsAndOpts :: PackageIdentifier -> (PackageName, (Version, Map FlagName Bool, [Text], Maybe GitSHA1)) - addFlagsAndOpts (PackageIdentifier name ver) = - ( name - , ( ver - , Map.findWithDefault Map.empty name flags - -- NOTE: similar to 'allGhcOptions' in Stack.Types.Build - , ghcOptionsFor name ghcOptions - -- we add a Nothing since we don't yet collect Git SHAs for custom snapshots - , Nothing - ) - ) - packageMap = Map.fromList $ map addFlagsAndOpts $ Set.toList packages - cv = fromMaybe (mbpCompilerVersion mbp0) mcompilerVersion - packages0 = - mbpPackages mbp0 `Map.difference` Map.fromSet (const ()) dropPackages - mbp1 <- toMiniBuildPlan cv mempty packageMap - return MiniBuildPlan - { mbpCompilerVersion = cv - , mbpPackages = Map.union (mbpPackages mbp1) packages0 - } diff --git a/src/Stack/Clean.hs b/src/Stack/Clean.hs --- a/src/Stack/Clean.hs +++ b/src/Stack/Clean.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} -- | Clean a project. module Stack.Clean @@ -9,53 +11,47 @@ ,StackCleanException(..) ) where -import Control.Exception (Exception) -import Control.Monad.Catch (throwM) -import Data.Foldable (forM_) +import Stack.Prelude import Data.List ((\\),intercalate) import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) -import Data.Typeable (Typeable) -import Path (Path, Abs, Dir) +import qualified Data.Text as T import Path.IO (ignoringAbsence, removeDirRecur) -import Stack.Build.Source (getLocalPackageViews) -import Stack.Build.Target (LocalPackageView(..)) import Stack.Config (getLocalPackages) -import Stack.Constants (distDirFromDir, workDirFromDir) +import Stack.Constants.Config (distDirFromDir, workDirFromDir) import Stack.Types.PackageName import Stack.Types.Config -import Stack.Types.StackT +import System.Exit (exitFailure) -- | Deletes build artifacts in the current project. -- -- Throws 'StackCleanException'. -clean - :: (StackM env m, HasEnvConfig env) - => CleanOpts - -> m () +clean :: HasEnvConfig env => CleanOpts -> RIO env () clean cleanOpts = do - dirs <- dirsToDelete cleanOpts - forM_ dirs (ignoringAbsence . removeDirRecur) + failures <- mapM cleanDir =<< dirsToDelete cleanOpts + when (or failures) $ liftIO exitFailure + where + cleanDir dir = + liftIO (ignoringAbsence (removeDirRecur dir) >> return False) `catchAny` \ex -> do + logError $ "Exception while recursively deleting " <> T.pack (toFilePath dir) <> "\n" <> T.pack (show ex) + logError "Perhaps you do not have permission to delete these files or they are in use?" + return True -dirsToDelete - :: (StackM env m, HasEnvConfig env) - => CleanOpts - -> m [Path Abs Dir] +dirsToDelete :: HasEnvConfig env => CleanOpts -> RIO env [Path Abs Dir] dirsToDelete cleanOpts = do packages <- getLocalPackages case cleanOpts of CleanShallow [] -> -- Filter out packages listed as extra-deps - mapM distDirFromDir . Map.keys . Map.filter (== False) $ packages + mapM (distDirFromDir . lpvRoot) $ Map.elems $ lpProject packages CleanShallow targets -> do - localPkgViews <- getLocalPackageViews - let localPkgNames = Map.keys localPkgViews - getPkgDir pkgName = fmap (lpvRoot . fst) (Map.lookup pkgName localPkgViews) + let localPkgViews = lpProject packages + localPkgNames = Map.keys localPkgViews + getPkgDir pkgName = fmap lpvRoot (Map.lookup pkgName localPkgViews) case targets \\ localPkgNames of [] -> mapM distDirFromDir (mapMaybe getPkgDir targets) xs -> throwM (NonLocalPackages xs) CleanFull -> do - pkgWorkDirs <- mapM workDirFromDir (Map.keys packages) + pkgWorkDirs <- mapM (workDirFromDir . lpvRoot) $ Map.elems $ lpProject packages projectWorkDir <- getProjectWorkDir return (projectWorkDir : pkgWorkDirs) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} @@ -33,7 +35,6 @@ ,loadConfigYaml ,packagesParser ,getLocalPackages - ,resolvePackageEntry ,getImplicitGlobalProjectDir ,getStackYaml ,getSnapshots @@ -44,43 +45,24 @@ ,defaultConfigYaml ,getProjectConfig ,LocalConfigStatus(..) - ,removePathFromPackageEntry ) where -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Zip as Zip -import qualified Codec.Compression.GZip as GZip -import Control.Applicative -import Control.Arrow ((***)) -import Control.Exception (assert) -import Control.Monad (liftM, unless, when, filterM) -import Control.Monad.Catch (MonadThrow, MonadCatch, catchAll, throwM, catch) import Control.Monad.Extra (firstJustM) -import Control.Monad.IO.Class -import Control.Monad.Logger hiding (Loc) -import Control.Monad.Reader (ask, runReaderT) -import Crypto.Hash (hashWith, SHA256(..)) +import Stack.Prelude import Data.Aeson.Extended -import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString as S -import qualified Data.ByteString.Base64.URL as B64URL -import qualified Data.ByteString.Lazy as L -import Data.Foldable (forM_) -import Data.IORef import qualified Data.IntMap as IntMap import qualified Data.Map as Map -import Data.Maybe -import Data.Monoid.Extra import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Text.Encoding (encodeUtf8) import qualified Data.Yaml as Yaml +import qualified Distribution.PackageDescription as C import Distribution.System (OS (..), Platform (..), buildPlatform, Arch(OtherArch)) import qualified Distribution.Text -import Distribution.Version (simplifyVersionRange) +import Distribution.Version (simplifyVersionRange, mkVersion') import GHC.Conc (getNumProcessors) import Lens.Micro (lens) import Network.HTTP.Client (parseUrlThrow) -import Network.HTTP.Download (download) import Network.HTTP.Simple (httpJSON, getResponseBody) import Options.Applicative (Parser, strOption, long, help) import Path @@ -88,31 +70,31 @@ import Path.Find (findInParents) import Path.IO import qualified Paths_stack as Meta -import Stack.BuildPlan import Stack.Config.Build import Stack.Config.Docker import Stack.Config.Nix import Stack.Config.Urls import Stack.Constants +import Stack.Fetch import qualified Stack.Image as Image +import Stack.PackageLocation +import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.Docker -import Stack.Types.Internal import Stack.Types.Nix +import Stack.Types.PackageName (PackageName) +import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex (IndexType (ITHackageSecurity), HackageSecurity (..)) import Stack.Types.Resolver -import Stack.Types.StackT -import Stack.Types.StringError +import Stack.Types.Runner import Stack.Types.Urls import Stack.Types.Version import System.Environment -import System.IO import System.PosixCompat.Files (fileOwner, getFileStatus) import System.PosixCompat.User (getEffectiveUserID) import System.Process.Read -import System.Process.Run -- | If deprecated path exists, use it and print a warning. -- Otherwise, return the new path. @@ -134,7 +116,7 @@ case mWarningDesc of Nothing -> return () Just desc -> - $logWarn $ T.concat + logWarn $ T.concat [ "Warning: Location of ", desc, " at '" , T.pack (toFilePath old) , "' is deprecated; rename it to '" @@ -161,9 +143,7 @@ -- | This is slightly more expensive than @'asks' ('bcStackYaml' '.' 'getBuildConfig')@ -- and should only be used when no 'BuildConfig' is at hand. -getStackYaml - :: (StackMiniM env m, HasConfig env) - => m (Path Abs File) +getStackYaml :: HasConfig env => RIO env (Path Abs File) getStackYaml = do config <- view configL case configMaybeProject config of @@ -171,28 +151,27 @@ Nothing -> liftM ( stackDotYaml) (getImplicitGlobalProjectDir config) -- | Download the 'Snapshots' value from stackage.org. -getSnapshots - :: (StackMiniM env m, HasConfig env) - => m Snapshots +getSnapshots :: HasConfig env => RIO env Snapshots getSnapshots = do latestUrlText <- askLatestSnapshotUrl latestUrl <- parseUrlThrow (T.unpack latestUrlText) - $logDebug $ "Downloading snapshot versions file from " <> latestUrlText + logDebug $ "Downloading snapshot versions file from " <> latestUrlText result <- httpJSON latestUrl - $logDebug $ "Done downloading and parsing snapshot versions file" + logDebug "Done downloading and parsing snapshot versions file" return $ getResponseBody result -- | Turn an 'AbstractResolver' into a 'Resolver'. makeConcreteResolver - :: (StackMiniM env m, HasConfig env) - => AbstractResolver - -> m Resolver -makeConcreteResolver (ARResolver r) = return r -makeConcreteResolver ar = do + :: HasConfig env + => Maybe (Path Abs Dir) -- ^ root of project for resolving custom relative paths + -> AbstractResolver + -> RIO env Resolver +makeConcreteResolver root (ARResolver r) = parseCustomLocation root r +makeConcreteResolver root ar = do snapshots <- getSnapshots r <- case ar of - ARResolver r -> assert False $ return r + ARResolver r -> assert False $ makeConcreteResolver root $ ARResolver r ARGlobal -> do config <- view configL implicitGlobalDir <- getImplicitGlobalProjectDir config @@ -203,18 +182,18 @@ ARLatestNightly -> return $ ResolverSnapshot $ Nightly $ snapshotsNightly snapshots ARLatestLTSMajor x -> case IntMap.lookup x $ snapshotsLts snapshots of - Nothing -> errorString $ "No LTS release found with major version " ++ show x + Nothing -> throwString $ "No LTS release found with major version " ++ show x Just y -> return $ ResolverSnapshot $ LTS x y ARLatestLTS - | IntMap.null $ snapshotsLts snapshots -> errorString "No LTS releases found" + | IntMap.null $ snapshotsLts snapshots -> throwString "No LTS releases found" | otherwise -> let (x, y) = IntMap.findMax $ snapshotsLts snapshots in return $ ResolverSnapshot $ LTS x y - $logInfo $ "Selected resolver: " <> resolverName r + logInfo $ "Selected resolver: " <> resolverRawName r return r -- | Get the latest snapshot resolver available. -getLatestResolver :: (StackMiniM env m, HasConfig env) => m Resolver +getLatestResolver :: HasConfig env => RIO env (ResolverWith a) getLatestResolver = do snapshots <- getSnapshots let mlts = do @@ -226,14 +205,14 @@ -- | Create a 'Config' value when we're not using any local -- configuration files (e.g., the script command) configNoLocalConfig - :: (MonadLogger m, MonadIO m, MonadCatch m) + :: (MonadLogger m, MonadUnliftIO m, MonadThrow m, MonadReader env m, HasRunner env) => Path Abs Dir -- ^ stack root -> Maybe AbstractResolver -> ConfigMonoid -> m Config -configNoLocalConfig _ Nothing _ = throwM NoResolverWhenUsingNoLocalConfig +configNoLocalConfig _ Nothing _ = throwIO NoResolverWhenUsingNoLocalConfig configNoLocalConfig stackRoot (Just resolver) configMonoid = do - userConfigPath <- getFakeConfigPath stackRoot resolver + userConfigPath <- liftIO $ getFakeConfigPath stackRoot resolver configFromConfigMonoid stackRoot userConfigPath @@ -244,7 +223,7 @@ -- Interprets ConfigMonoid options. configFromConfigMonoid - :: (MonadLogger m, MonadIO m, MonadCatch m) + :: (MonadLogger m, MonadUnliftIO m, MonadThrow m, MonadReader env m, HasRunner env) => Path Abs Dir -- ^ stack root, e.g. ~/.stack -> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml -> Bool -- ^ allow locals? @@ -258,12 +237,12 @@ -- If --stack-work is passed, prefer it. Otherwise, if STACK_WORK -- is set, use that. If neither, use the default ".stack-work" mstackWorkEnv <- liftIO $ lookupEnv stackWorkEnvVar - configWorkDir0 <- maybe (return $(mkRelDir ".stack-work")) parseRelDir mstackWorkEnv + configWorkDir0 <- maybe (return $(mkRelDir ".stack-work")) (liftIO . parseRelDir) mstackWorkEnv let configWorkDir = fromFirst configWorkDir0 configMonoidWorkDir -- This code is to handle the deprecation of latest-snapshot-url configUrls <- case (getFirst configMonoidLatestSnapshotUrl, getFirst (urlsMonoidLatestSnapshot configMonoidUrls)) of (Just url, Nothing) -> do - $logWarn "The latest-snapshot-url field is deprecated in favor of 'urls' configuration" + logWarn "The latest-snapshot-url field is deprecated in favor of 'urls' configuration" return (urlsFromMonoid configMonoidUrls) { urlsLatestSnapshot = url } _ -> return (urlsFromMonoid configMonoidUrls) let configConnectionCount = fromFirst 8 configMonoidConnectionCount @@ -293,14 +272,15 @@ configGHCVariant0 = getFirst configMonoidGHCVariant configGHCBuild = getFirst configMonoidGHCBuild - configInstallGHC = fromFirst False configMonoidInstallGHC + configInstallGHC = fromFirst True configMonoidInstallGHC configSkipGHCCheck = fromFirst False configMonoidSkipGHCCheck configSkipMsys = fromFirst False configMonoidSkipMsys configExtraIncludeDirs = configMonoidExtraIncludeDirs configExtraLibDirs = configMonoidExtraLibDirs configOverrideGccPath = getFirst configMonoidOverrideGccPath - + configOverrideHpack = maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack + -- Only place in the codebase where platform is hard-coded. In theory -- in the future, allow it to be configured. (Platform defArch defOS) = buildPlatform @@ -316,7 +296,7 @@ configCompilerCheck = fromFirst MatchMinor configMonoidCompilerCheck case arch of - OtherArch unk -> $logWarn $ "Warning: Unknown value for architecture setting: " <> T.pack (show unk) + OtherArch unk -> logWarn $ "Warning: Unknown value for architecture setting: " <> T.pack (show unk) _ -> return () configPlatformVariant <- liftIO $ @@ -366,8 +346,8 @@ -- TODO: Either catch specific exceptions or add a -- parseRelAsAbsDirMaybe utility and use it along with -- resolveDirMaybe. - `catchAll` - const (throwM (NoSuchDirectory userPath)) + `catchAny` + const (throwIO (NoSuchDirectory userPath)) configJobs <- case getFirst configMonoidJobs of @@ -377,7 +357,8 @@ let configTemplateParams = configMonoidTemplateParameters configScmInit = getFirst configMonoidScmInit - configGhcOptions = configMonoidGhcOptions + configGhcOptionsByName = configMonoidGhcOptionsByName + configGhcOptionsByCat = configMonoidGhcOptionsByCat configSetupInfoLocations = configMonoidSetupInfoLocations configPvpBounds = fromFirst (PvpBounds PvpBoundsNone False) configMonoidPvpBounds configModifyCodePage = fromFirst True configMonoidModifyCodePage @@ -388,16 +369,19 @@ configDefaultTemplate = getFirst configMonoidDefaultTemplate configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds + configIgnoreRevisionMismatch = fromFirst False configMonoidIgnoreRevisionMismatch configAllowDifferentUser <- case getFirst configMonoidAllowDifferentUser of Just True -> return True _ -> getInContainer - configPackageCaches <- liftIO $ newIORef Nothing + configPackageCache <- liftIO $ newIORef Nothing let configMaybeProject = mproject + configRunner <- view runnerL + return Config {..} -- | Get the default location of the local programs directory. @@ -419,13 +403,13 @@ case Map.lookup "LOCALAPPDATA" $ unEnvOverride override of Just t -> case parseAbsDir $ T.unpack t of - Nothing -> throwString ("Failed to parse LOCALAPPDATA environment variable (expected absolute directory): " ++ show t) + Nothing -> throwM $ stringException ("Failed to parse LOCALAPPDATA environment variable (expected absolute directory): " ++ show t) Just lad -> return $ lad $(mkRelDir "Programs") $(mkRelDir stackProgName) Nothing -> return defaultBase _ -> return defaultBase -- | An environment with a subset of BuildConfig used for setup. -data MiniConfig = MiniConfig +data MiniConfig = MiniConfig -- TODO do we really need a whole extra data type? { mcGHCVariant :: !GHCVariant , mcConfig :: !Config } @@ -434,24 +418,32 @@ instance HasPlatform MiniConfig instance HasGHCVariant MiniConfig where ghcVariantL = lens mcGHCVariant (\x y -> x { mcGHCVariant = y }) +instance HasRunner MiniConfig where + runnerL = configL.runnerL +instance HasLogFunc MiniConfig where + logFuncL = configL.logFuncL -- | Load the 'MiniConfig'. loadMiniConfig :: Config -> MiniConfig -loadMiniConfig config = - let ghcVariant = fromMaybe GHCStandard (configGHCVariant0 config) - in MiniConfig ghcVariant config +loadMiniConfig config = MiniConfig + { mcGHCVariant = configGHCVariantDefault config + , mcConfig = config + } +configGHCVariantDefault :: Config -> GHCVariant -- FIXME why not just use this as the HasGHCVariant instance for Config? +configGHCVariantDefault = fromMaybe GHCStandard . configGHCVariant0 + -- Load the configuration, using environment variables, and defaults as -- necessary. loadConfigMaybeProject - :: StackM env m + :: HasRunner env => ConfigMonoid -- ^ Config monoid from parsed command-line arguments -> Maybe AbstractResolver -- ^ Override resolver -> LocalConfigStatus (Project, Path Abs File, ConfigMonoid) -- ^ Project config to use, if any - -> m (LoadConfig m) + -> RIO env LoadConfig loadConfigMaybeProject configArgs mresolver mproject = do (stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership configArgs @@ -477,10 +469,10 @@ config <- case mproject of - LCSNoConfig -> configNoLocalConfig stackRoot mresolver configArgs + LCSNoConfig _ -> configNoLocalConfig stackRoot mresolver configArgs LCSProject project -> loadHelper $ Just project LCSNoProject -> loadHelper Nothing - unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config) + unless (fromCabalVersion (mkVersion' Meta.version) `withinRange` configRequireStackVersion config) (throwM (BadStackVersionException (configRequireStackVersion config))) let mprojectRoot = fmap (\(_, fp, _) -> parent fp) mproject @@ -492,48 +484,79 @@ return LoadConfig { lcConfig = config - , lcLoadBuildConfig = loadBuildConfig mproject config mresolver + , lcLoadBuildConfig = runRIO config . loadBuildConfig mproject mresolver , lcProjectRoot = case mprojectRoot of LCSProject fp -> Just fp LCSNoProject -> Nothing - LCSNoConfig -> Nothing + LCSNoConfig _ -> Nothing } -- | Load the configuration, using current directory, environment variables, -- and defaults as necessary. The passed @Maybe (Path Abs File)@ is an -- override for the location of the project's stack.yaml. -loadConfig :: StackM env m +loadConfig :: HasRunner env => ConfigMonoid -- ^ Config monoid from parsed command-line arguments -> Maybe AbstractResolver -- ^ Override resolver -> StackYamlLoc (Path Abs File) -- ^ Override stack.yaml - -> m (LoadConfig m) + -> RIO env LoadConfig loadConfig configArgs mresolver mstackYaml = loadProjectConfig mstackYaml >>= loadConfigMaybeProject configArgs mresolver -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values. -loadBuildConfig :: StackM env m - => LocalConfigStatus (Project, Path Abs File, ConfigMonoid) - -> Config +loadBuildConfig :: LocalConfigStatus (Project, Path Abs File, ConfigMonoid) -> Maybe AbstractResolver -- override resolver - -> Maybe CompilerVersion -- override compiler - -> m BuildConfig -loadBuildConfig mproject config mresolver mcompiler = do - env <- ask + -> Maybe (CompilerVersion 'CVWanted) -- override compiler + -> RIO Config BuildConfig +loadBuildConfig mproject maresolver mcompiler = do + config <- ask + -- If provided, turn the AbstractResolver from the command line + -- into a Resolver that can be used below. + + -- The maresolver and mcompiler are provided on the command + -- line. In order to properly deal with an AbstractResolver, we + -- need a base directory (to deal with custom snapshot relative + -- paths). We consider the current working directory to be the + -- correct base. Let's calculate the mresolver first. + mresolver <- forM maresolver $ \aresolver -> do + -- For display purposes only + let name = + case aresolver of + ARResolver resolver -> resolverRawName resolver + ARLatestNightly -> "nightly" + ARLatestLTS -> "lts" + ARLatestLTSMajor x -> T.pack $ "lts-" ++ show x + ARGlobal -> "global" + logDebug ("Using resolver: " <> name <> " specified on command line") + + -- In order to resolve custom snapshots, we need a base + -- directory to deal with relative paths. For the case of + -- LCSNoConfig, we use the parent directory provided. This is + -- because, when running the script interpreter, we assume the + -- resolver is in fact coming from the file contents itself and + -- not the command line. For the project and non project cases, + -- however, we use the current directory. + base <- + case mproject of + LCSNoConfig parentDir -> return parentDir + LCSProject _ -> resolveDir' "." + LCSNoProject -> resolveDir' "." + makeConcreteResolver (Just base) aresolver + (project', stackYamlFP) <- case mproject of LCSProject (project, fp, _) -> do - forM_ (projectUserMsg project) ($logWarn . T.pack) + forM_ (projectUserMsg project) (logWarn . T.pack) return (project, fp) - LCSNoConfig -> do - p <- getEmptyProject + LCSNoConfig _ -> do + p <- assert (isJust mresolver) (getEmptyProject mresolver) return (p, configUserConfigPath config) LCSNoProject -> do - $logDebug "Run from outside a project, using implicit global project config" + logDebug "Run from outside a project, using implicit global project config" destDir <- getImplicitGlobalProjectDir config let dest :: Path Abs File dest = destDir stackDotYaml @@ -544,26 +567,17 @@ if exists then do ProjectAndConfigMonoid project _ <- loadConfigYaml (parseProjectAndConfigMonoid destDir) dest - when (view terminalL env) $ - case mresolver of + when (view terminalL config) $ + case maresolver of Nothing -> - $logDebug ("Using resolver: " <> resolverName (projectResolver project) <> + logDebug ("Using resolver: " <> resolverRawName (projectResolver project) <> " from implicit global project's config file: " <> T.pack dest') - Just aresolver -> do - let name = - case aresolver of - ARResolver resolver -> resolverName resolver - ARLatestNightly -> "nightly" - ARLatestLTS -> "lts" - ARLatestLTSMajor x -> T.pack $ "lts-" ++ show x - ARGlobal -> "global" - $logDebug ("Using resolver: " <> name <> - " specified on command line") + Just _ -> return () return (project, dest) else do - $logInfo ("Writing implicit global project config file to: " <> T.pack dest') - $logInfo "Note: You can change the snapshot via the resolver field there." - p <- getEmptyProject + logInfo ("Writing implicit global project config file to: " <> T.pack dest') + logInfo "Note: You can change the snapshot via the resolver field there." + p <- getEmptyProject mresolver liftIO $ do S.writeFile dest' $ S.concat [ "# This is the implicit global project's config file, which is only used when\n" @@ -579,31 +593,22 @@ [ "This is the implicit global project, which is used only when 'stack' is run\n" , "outside of a real project.\n" ] return (p, dest) - resolver <- - case mresolver of - Nothing -> return $ projectResolver project' - Just aresolver -> - runReaderT (makeConcreteResolver aresolver) miniConfig let project = project' - { projectResolver = resolver - , projectCompiler = mcompiler <|> projectCompiler project' + { projectCompiler = mcompiler <|> projectCompiler project' + , projectResolver = fromMaybe (projectResolver project') mresolver } - (mbp0, loadedResolver) <- flip runReaderT miniConfig $ - loadResolver (Just stackYamlFP) (projectResolver project) - let mbp = case projectCompiler project of - Just compiler -> mbp0 { mbpCompilerVersion = compiler } - Nothing -> mbp0 + sd0 <- runRIO config $ loadResolver $ projectResolver project + let sd = maybe id setCompilerVersion (projectCompiler project) sd0 extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) return BuildConfig { bcConfig = config - , bcResolver = loadedResolver - , bcWantedMiniBuildPlan = mbp - , bcGHCVariant = view ghcVariantL miniConfig - , bcPackageEntries = projectPackages project - , bcExtraDeps = projectExtraDeps project + , bcSnapshotDef = sd + , bcGHCVariant = configGHCVariantDefault config + , bcPackages = projectPackages project + , bcDependencies = projectDependencies project , bcExtraPackageDBs = extraPackageDBs , bcStackYaml = stackYamlFP , bcFlags = projectFlags project @@ -611,25 +616,23 @@ case mproject of LCSNoProject -> True LCSProject _ -> False - LCSNoConfig -> False + LCSNoConfig _ -> False } where - miniConfig = loadMiniConfig config - - getEmptyProject = do + getEmptyProject :: Maybe Resolver -> RIO Config Project + getEmptyProject mresolver = do r <- case mresolver of - Just aresolver -> do - r' <- runReaderT (makeConcreteResolver aresolver) miniConfig - $logInfo ("Using resolver: " <> resolverName r' <> " specified on command line") - return r' + Just resolver -> do + logInfo ("Using resolver: " <> resolverRawName resolver <> " specified on command line") + return resolver Nothing -> do - r'' <- runReaderT getLatestResolver miniConfig - $logInfo ("Using latest snapshot resolver: " <> resolverName r'') + r'' <- getLatestResolver + logInfo ("Using latest snapshot resolver: " <> resolverRawName r'') return r'' return Project { projectUserMsg = Nothing - , projectPackages = mempty - , projectExtraDeps = mempty + , projectPackages = [] + , projectDependencies = [] , projectFlags = mempty , projectResolver = r , projectCompiler = Nothing @@ -638,199 +641,64 @@ -- | Get packages from EnvConfig, downloading and cloning as necessary. -- If the packages have already been downloaded, this uses a cached value ( -getLocalPackages - :: (StackMiniM env m, HasEnvConfig env) - => m (Map.Map (Path Abs Dir) TreatLikeExtraDep) +getLocalPackages :: forall env. HasEnvConfig env => RIO env LocalPackages getLocalPackages = do cacheRef <- view $ envConfigL.to envConfigPackagesRef mcached <- liftIO $ readIORef cacheRef case mcached of Just cached -> return cached - Nothing -> do - menv <- getMinimalEnvOverride + Nothing -> withCabalLoader $ \loadFromIndex -> do root <- view projectRootL - entries <- view $ buildConfigL.to bcPackageEntries - liftM (Map.fromList . concat) $ mapM - (resolvePackageEntry menv root) - entries - --- | Resolve a PackageEntry into a list of paths, downloading and cloning as --- necessary. -resolvePackageEntry - :: (StackMiniM env m, HasConfig env) - => EnvOverride - -> Path Abs Dir -- ^ project root - -> PackageEntry - -> m [(Path Abs Dir, TreatLikeExtraDep)] -resolvePackageEntry menv projRoot pe = do - entryRoot <- resolvePackageLocation menv projRoot (peLocation pe) - paths <- - case peSubdirs pe of - [] -> return [entryRoot] - subs -> mapM (resolveDir entryRoot) subs - extraDep <- - case peExtraDepMaybe pe of - Just e -> return e - Nothing -> - case peLocation pe of - PLFilePath _ -> - -- we don't give a warning on missing explicit - -- value here, user intent is almost always - -- the default for a local directory - return False - PLRemote url _ -> do - $logWarn $ mconcat - [ "No extra-dep setting found for package at URL:\n\n" - , url - , "\n\n" - , "This is usually a mistake, external packages " - , "should typically\nbe treated as extra-deps to avoid " - , "spurious test case failures." - ] - return False - return $ map (, extraDep) paths - --- | Resolve a PackageLocation into a path, downloading and cloning as --- necessary. -resolvePackageLocation - :: (StackMiniM env m, HasConfig env) - => EnvOverride - -> Path Abs Dir -- ^ project root - -> PackageLocation - -> m (Path Abs Dir) -resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp -resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do - workDir <- view workDirL - let nameBeforeHashing = case remotePackageType of - RPTHttp{} -> url - RPTGit commit -> T.unwords [url, commit] - RPTHg commit -> T.unwords [url, commit, "hg"] - -- TODO: dedupe with code for snapshot hash? - name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 nameBeforeHashing - root = projRoot workDir $(mkRelDir "downloaded") - fileExtension' = case remotePackageType of - RPTHttp -> ".http-archive" - _ -> ".unused" - - fileRel <- parseRelFile $ name ++ fileExtension' - dirRel <- parseRelDir name - dirRelTmp <- parseRelDir $ name ++ ".tmp" - let file = root fileRel - dir = root dirRel - - exists <- doesDirExist dir - unless exists $ do - ignoringAbsence (removeDirRecur dir) - - let cloneAndExtract commandName cloneArgs resetCommand commit = do - ensureDir root - callProcessInheritStderrStdout Cmd - { cmdDirectoryToRunIn = Just root - , cmdCommandToRun = commandName - , cmdEnvOverride = menv - , cmdCommandLineArguments = - "clone" : - cloneArgs ++ - [ T.unpack url - , toFilePathNoTrailingSep dir - ] - } - created <- doesDirExist dir - unless created $ throwM $ FailedToCloneRepo commandName - readProcessNull (Just dir) menv commandName - (resetCommand ++ [T.unpack commit, "--"]) - `catch` \case - ex@ProcessFailed{} -> do - $logInfo $ "Please ensure that commit " <> commit <> " exists within " <> url - throwM ex - ex -> throwM ex - - case remotePackageType of - RPTHttp -> do - let dirTmp = root dirRelTmp - ignoringAbsence (removeDirRecur dirTmp) - - let fp = toFilePath file - req <- parseUrlThrow $ T.unpack url - _ <- download req file - - let tryTar = do - $logDebug $ "Trying to untar " <> T.pack fp - liftIO $ withBinaryFile fp ReadMode $ \h -> do - lbs <- L.hGetContents h - let entries = Tar.read $ GZip.decompress lbs - Tar.unpack (toFilePath dirTmp) entries - tryZip = do - $logDebug $ "Trying to unzip " <> T.pack fp - archive <- fmap Zip.toArchive $ liftIO $ L.readFile fp - liftIO $ Zip.extractFilesFromArchive [Zip.OptDestination - (toFilePath dirTmp)] archive - err = throwM $ UnableToExtractArchive url file - - catchAllLog goodpath handler = - catchAll goodpath $ \e -> do - $logDebug $ "Got exception: " <> T.pack (show e) - handler + bc <- view buildConfigL - tryTar `catchAllLog` tryZip `catchAllLog` err - renameDir dirTmp dir + packages <- do + let withName lpv = (lpvName lpv, lpv) + map withName . concat <$> mapM (parseMultiCabalFiles root True) (bcPackages bc) - -- Passes in --git-dir to git and --repository to hg, in order - -- to avoid the update commands being applied to the user's - -- repo. See https://github.com/commercialhaskell/stack/issues/2748 - RPTGit commit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"] commit - RPTHg commit -> cloneAndExtract "hg" [] ["--repository", ".", "update", "-C"] commit + let wrapGPD (gpd, loc) = + let PackageIdentifier name _version = + fromCabalPackageIdentifier + $ C.package + $ C.packageDescription gpd + in (name, (gpd, loc)) + deps <- (map wrapGPD . concat) + <$> mapM (parseMultiCabalFilesIndex loadFromIndex root) (bcDependencies bc) - case remotePackageType of - RPTHttp -> do - x <- listDir dir - case x of - ([dir'], []) -> return dir' - (dirs, files) -> do - ignoringAbsence (removeFile file) - ignoringAbsence (removeDirRecur dir) - throwM $ UnexpectedArchiveContents dirs files - _ -> return dir + checkDuplicateNames $ + map (second (PLOther . lpvLoc)) packages ++ + map (second snd) deps --- | Remove path from package entry. If the package entry contains subdirs, then it removes --- the subdir. If the package entry points to the path to remove, this function returns --- Nothing. If the package entry doesn't mention the path to remove, it is returned unchanged -removePathFromPackageEntry - :: (StackMiniM env m, HasConfig env) - => EnvOverride - -> Path Abs Dir -- ^ project root - -> Path Abs Dir -- ^ path to remove - -> PackageEntry - -> m (Maybe PackageEntry) - -- ^ Nothing if the whole package entry should be removed, otherwise - -- it returns the updated PackageEntry -removePathFromPackageEntry menv projectRoot pathToRemove packageEntry = do - locationPath <- resolvePackageLocation menv projectRoot (peLocation packageEntry) - case peSubdirs packageEntry of - [] -> if locationPath == pathToRemove then return Nothing else return (Just packageEntry) - subdirPaths -> do - let shouldKeepSubdir path = do - resolvedPath <- resolveDir locationPath path - return (pathToRemove /= resolvedPath) - filteredSubdirs <- filterM shouldKeepSubdir subdirPaths - if null filteredSubdirs then return Nothing else return (Just packageEntry {peSubdirs = filteredSubdirs}) + return LocalPackages + { lpProject = Map.fromList packages + , lpDependencies = Map.fromList deps + } +-- | Check if there are any duplicate package names and, if so, throw an +-- exception. +checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocationIndex FilePath)] -> m () +checkDuplicateNames locals = + case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map (second return) locals of + [] -> return () + x -> throwM $ DuplicateLocalPackageNames x + where + hasMultiples (_, _:_:_) = True + hasMultiples _ = False -- | Get the stack root, e.g. @~/.stack@, and determine whether the user owns it. -- -- On Windows, the second value is always 'True'. determineStackRootAndOwnership - :: (MonadIO m, MonadCatch m) + :: (MonadIO m) => ConfigMonoid -- ^ Parsed command-line arguments -> m (Path Abs Dir, Bool) -determineStackRootAndOwnership clArgs = do +determineStackRootAndOwnership clArgs = liftIO $ do stackRoot <- do case getFirst (configMonoidStackRoot clArgs) of Just x -> return x Nothing -> do - mstackRoot <- liftIO $ lookupEnv stackRootEnvVar + mstackRoot <- lookupEnv stackRootEnvVar case mstackRoot of Nothing -> getAppUserDataDir stackProgName Just x -> case parseAbsDir x of @@ -841,12 +709,12 @@ mdirAndOwnership <- findInParents getDirAndOwnership stackRoot case mdirAndOwnership of Just x -> return x - Nothing -> throwM (BadStackRoot stackRoot) + Nothing -> throwIO (BadStackRoot stackRoot) when (existingStackRootOrParentDir /= stackRoot) $ if userOwnsIt - then liftIO $ ensureDir stackRoot - else throwM $ + then ensureDir stackRoot + else throwIO $ Won'tCreateStackRootInDirectoryOwnedByDifferentUser stackRoot existingStackRootOrParentDir @@ -860,22 +728,22 @@ -- If @dir@ doesn't exist, its parent directory is checked instead. -- If the parent directory doesn't exist either, @'NoSuchDirectory' ('parent' dir)@ -- is thrown. -checkOwnership :: (MonadIO m, MonadCatch m) => Path Abs Dir -> m () +checkOwnership :: (MonadIO m) => Path Abs Dir -> m () checkOwnership dir = do mdirAndOwnership <- firstJustM getDirAndOwnership [dir, parent dir] case mdirAndOwnership of Just (_, True) -> return () - Just (dir', False) -> throwM (UserDoesn'tOwnDirectory dir') + Just (dir', False) -> throwIO (UserDoesn'tOwnDirectory dir') Nothing -> - (throwM . NoSuchDirectory) $ (toFilePathNoTrailingSep . parent) dir + (throwIO . NoSuchDirectory) $ (toFilePathNoTrailingSep . parent) dir -- | @'getDirAndOwnership' dir@ returns @'Just' (dir, 'True')@ when @dir@ -- exists and the current user owns it in the sense of 'isOwnedByUser'. getDirAndOwnership - :: (MonadIO m, MonadCatch m) + :: (MonadIO m) => Path Abs Dir -> m (Maybe (Path Abs Dir, Bool)) -getDirAndOwnership dir = forgivingAbsence $ do +getDirAndOwnership dir = liftIO $ forgivingAbsence $ do ownership <- isOwnedByUser dir return (dir, ownership) @@ -962,7 +830,7 @@ env <- liftIO getEnvironment case lookup "STACK_YAML" env of Just fp -> do - $logInfo "Getting project config file from STACK_YAML environment" + logInfo "Getting project config file from STACK_YAML environment" liftM LCSProject $ resolveFile' fp Nothing -> do currDir <- getCurrentDir @@ -971,17 +839,18 @@ getStackDotYaml dir = do let fp = dir stackDotYaml fp' = toFilePath fp - $logDebug $ "Checking for project config at: " <> T.pack fp' + logDebug $ "Checking for project config at: " <> T.pack fp' exists <- doesFileExist fp if exists then return $ Just fp else return Nothing -getProjectConfig SYLNoConfig = return LCSNoConfig +getProjectConfig (SYLNoConfig parentDir) = return (LCSNoConfig parentDir) data LocalConfigStatus a = LCSNoProject | LCSProject a - | LCSNoConfig + | LCSNoConfig !(Path Abs Dir) + -- ^ parent directory for making a concrete resolving deriving (Show,Functor,Foldable,Traversable) -- | Find the project config file location, respecting environment variables @@ -996,15 +865,15 @@ case mfp of LCSProject fp -> do currDir <- getCurrentDir - $logDebug $ "Loading project config file " <> - T.pack (maybe (toFilePath fp) toFilePath (stripDir currDir fp)) + logDebug $ "Loading project config file " <> + T.pack (maybe (toFilePath fp) toFilePath (stripProperPrefix currDir fp)) LCSProject <$> load fp LCSNoProject -> do - $logDebug $ "No project config file found, using defaults." + logDebug "No project config file found, using defaults." return LCSNoProject - LCSNoConfig -> do - $logDebug "Ignoring config files" - return LCSNoConfig + LCSNoConfig mparentDir -> do + logDebug "Ignoring config files" + return (LCSNoConfig mparentDir) where load fp = do ProjectAndConfigMonoid project config <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp @@ -1055,9 +924,15 @@ getFakeConfigPath stackRoot ar = do asString <- case ar of - ARResolver r -> return $ T.unpack $ resolverName r + ARResolver r -> return $ T.unpack $ resolverRawName r _ -> throwM $ InvalidResolverForNoLocalConfig $ show ar - asDir <- parseRelDir asString + -- This takeWhile is an ugly hack. We don't actually need this + -- path for anything useful. But if we take the raw value for + -- a custom snapshot, it will be unparseable in a PATH. + -- Therefore, we add in this silly "strip up to :". + -- Better would be to defer figuring out this value until + -- after we have a fully loaded snapshot with a hash. + asDir <- parseRelDir $ takeWhile (/= ':') asString let full = stackRoot $(mkRelDir "script") asDir $(mkRelFile "config.yaml") ensureDir (parent full) return full diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs --- a/src/Stack/Config/Build.hs +++ b/src/Stack/Config/Build.hs @@ -1,10 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards #-} -- | Build configuration module Stack.Config.Build where -import Data.Maybe -import Data.Monoid.Extra +import Stack.Prelude import Stack.Types.Config -- | Interprets BuildOptsMonoid options. @@ -43,6 +43,9 @@ , boptsInstallExes = fromFirst (boptsInstallExes defaultBuildOpts) buildMonoidInstallExes + , boptsInstallCompilerTool = fromFirst + (boptsInstallCompilerTool defaultBuildOpts) + buildMonoidInstallCompilerTool , boptsPreFetch = fromFirst (boptsPreFetch defaultBuildOpts) buildMonoidPreFetch @@ -67,6 +70,7 @@ , boptsSplitObjs = fromFirst (boptsSplitObjs defaultBuildOpts) buildMonoidSplitObjs + , boptsSkipComponents = buildMonoidSkipComponents } where -- These options are not directly used in bopts, instead they diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -1,18 +1,14 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP, DeriveDataTypeable, RecordWildCards, TemplateHaskell #-} -- | Docker configuration module Stack.Config.Docker where -import Control.Exception.Lifted -import Control.Monad.Catch (MonadThrow) +import Stack.Prelude import Data.List (find) -import Data.Maybe -import Data.Monoid.Extra import qualified Data.Text as T -import Data.Typeable (Typeable) import Distribution.Version (simplifyVersionRange) import Path -import Stack.Types.BuildPlan import Stack.Types.Version import Stack.Types.Config import Stack.Types.Docker @@ -33,13 +29,13 @@ let mresolver = case maresolver of Just (ARResolver resolver) -> - Just resolver + Just (void resolver) Just aresolver -> - throw + impureThrow (ResolverNotSupportedException $ show aresolver) Nothing -> - fmap projectResolver mproject + fmap (void . projectResolver) mproject defaultTag = case mresolver of Nothing -> "" @@ -48,7 +44,7 @@ ResolverSnapshot n@(LTS _ _) -> ":" ++ T.unpack (renderSnapName n) _ -> - throw + impureThrow (ResolverNotSupportedException $ show resolver) in case getFirst dockerMonoidRepoOrImage of @@ -78,6 +74,7 @@ simplifyVersionRange (getIntersectingVersionRange dockerMonoidRequireDockerVersion) dockerDatabasePath = fromFirst (stackRoot $(mkRelFile "docker.db")) dockerMonoidDatabasePath dockerStackExe = getFirst dockerMonoidStackExe + return DockerOpts{..} where emptyToNothing Nothing = Nothing emptyToNothing (Just s) | null s = Nothing diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards, DeriveDataTypeable, OverloadedStrings #-} -- | Nix configuration @@ -7,23 +8,16 @@ ,StackNixException(..) ) where -import Control.Monad (when) -import Data.Maybe -import Data.Monoid.Extra +import Stack.Prelude import qualified Data.Text as T -import Data.Typeable import Distribution.System (OS (..)) import Stack.Types.Version import Stack.Types.Nix import Stack.Types.Compiler -import Stack.Types.StringError -import Control.Exception.Lifted -import Control.Monad.Catch (throwM,MonadCatch) -import Prelude -- | Interprets NixOptsMonoid options. nixOptsFromMonoid - :: (Monad m, MonadCatch m) + :: MonadUnliftIO m => NixOptsMonoid -> OS -> m NixOpts @@ -39,15 +33,16 @@ ++ prefixAll (T.pack "-I") (fromFirst [] nixMonoidPath) nixAddGCRoots = fromFirst False nixMonoidAddGCRoots when (not (null nixPackages) && isJust nixInitFile) $ - throwM NixCannotUseShellFileAndPackagesException + throwIO NixCannotUseShellFileAndPackagesException return NixOpts{..} where prefixAll p (x:xs) = p : x : prefixAll p xs prefixAll _ _ = [] -nixCompiler :: CompilerVersion -> T.Text +nixCompiler :: CompilerVersion a -> Either StringException T.Text nixCompiler compilerVersion = let -- These are the latest minor versions for each respective major version available in nixpkgs - fixMinor "8.0" = "8.0.1" + fixMinor "8.2" = "8.2.1" + fixMinor "8.0" = "8.0.2" fixMinor "7.10" = "7.10.3" fixMinor "7.8" = "7.8.4" fixMinor "7.6" = "7.6.3" @@ -60,8 +55,8 @@ (T.filter (/= '.') (fixMinor (versionText v))) in case compilerVersion of - GhcVersion v -> nixCompilerFromVersion v - _ -> errorString "Only GHC is supported by stack --nix" + GhcVersion v -> Right $ nixCompilerFromVersion v + _ -> Left $ stringException "Only GHC is supported by stack --nix" -- Exceptions thown specifically by Stack.Nix data StackNixException diff --git a/src/Stack/Config/Urls.hs b/src/Stack/Config/Urls.hs --- a/src/Stack/Config/Urls.hs +++ b/src/Stack/Config/Urls.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Stack.Config.Urls (urlsFromMonoid) where import Stack.Types.Urls -import Data.Monoid.Extra +import Stack.Prelude urlsFromMonoid :: UrlsMonoid -> Urls urlsFromMonoid monoid = diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GADTs #-} -- | Make changes to project or global configuration. @@ -13,28 +13,20 @@ ,cfgCmdSetName ,cfgCmdName) where -import Control.Applicative -import Control.Monad -import Control.Monad.Catch (throwM) -import Control.Monad.IO.Class -import Control.Monad.Logger +import Stack.Prelude import qualified Data.ByteString as S import qualified Data.HashMap.Strict as HMap -import Data.Monoid -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Yaml as Yaml import qualified Options.Applicative as OA import qualified Options.Applicative.Types as OA import Path import Path.IO -import Prelude -- Silence redundant import warnings -import Stack.BuildPlan import Stack.Config (makeConcreteResolver, getProjectConfig, getImplicitGlobalProjectDir, LocalConfigStatus(..)) import Stack.Constants +import Stack.Snapshot (loadResolver) import Stack.Types.Config import Stack.Types.Resolver -import Stack.Types.StringError data ConfigCmdSet = ConfigCmdSetResolver AbstractResolver @@ -56,51 +48,46 @@ configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope cfgCmdSet - :: (StackMiniM env m, HasConfig env, HasGHCVariant env) - => GlobalOpts -> ConfigCmdSet -> m () + :: (HasConfig env, HasGHCVariant env) + => GlobalOpts -> ConfigCmdSet -> RIO env () cfgCmdSet go cmd = do conf <- view configL configFilePath <- - liftM - toFilePath - (case configCmdSetScope cmd of + case configCmdSetScope cmd of CommandScopeProject -> do mstackYamlOption <- forM (globalStackYaml go) resolveFile' mstackYaml <- getProjectConfig mstackYamlOption case mstackYaml of LCSProject stackYaml -> return stackYaml LCSNoProject -> liftM ( stackDotYaml) (getImplicitGlobalProjectDir conf) - LCSNoConfig -> errorString "config command used when no local configuration available" - CommandScopeGlobal -> return (configUserConfigPath conf)) + LCSNoConfig _ -> throwString "config command used when no local configuration available" + CommandScopeGlobal -> return (configUserConfigPath conf) -- We don't need to worry about checking for a valid yaml here (config :: Yaml.Object) <- - liftIO (Yaml.decodeFileEither configFilePath) >>= either throwM return - newValue <- cfgCmdSetValue cmd + liftIO (Yaml.decodeFileEither (toFilePath configFilePath)) >>= either throwM return + newValue <- cfgCmdSetValue (parent configFilePath) cmd let cmdKey = cfgCmdSetOptionName cmd config' = HMap.insert cmdKey newValue config if config' == config - then $logInfo - (T.pack configFilePath <> + then logInfo + (T.pack (toFilePath configFilePath) <> " already contained the intended configuration and remains unchanged.") else do - liftIO (S.writeFile configFilePath (Yaml.encode config')) - $logInfo (T.pack configFilePath <> " has been updated.") + liftIO (S.writeFile (toFilePath configFilePath) (Yaml.encode config')) + logInfo (T.pack (toFilePath configFilePath) <> " has been updated.") cfgCmdSetValue - :: (StackMiniM env m, HasConfig env, HasGHCVariant env) - => ConfigCmdSet -> m Yaml.Value -cfgCmdSetValue (ConfigCmdSetResolver newResolver) = do - concreteResolver <- makeConcreteResolver newResolver - case concreteResolver of - -- Check that the snapshot actually exists - ResolverSnapshot snapName -> void $ loadMiniBuildPlan snapName - ResolverCompiler _ -> return () - -- TODO: custom snapshot support? Would need a way to specify on CLI - ResolverCustom _ _ -> errorString "'stack config set resolver' does not support custom resolvers" - return (Yaml.String (resolverName concreteResolver)) -cfgCmdSetValue (ConfigCmdSetSystemGhc _ bool) = + :: (HasConfig env, HasGHCVariant env) + => Path Abs Dir -- ^ root directory of project + -> ConfigCmdSet -> RIO env Yaml.Value +cfgCmdSetValue root (ConfigCmdSetResolver newResolver) = do + concreteResolver <- makeConcreteResolver (Just root) newResolver + -- Check that the snapshot actually exists + void $ loadResolver concreteResolver + return (Yaml.toJSON concreteResolver) +cfgCmdSetValue _ (ConfigCmdSetSystemGhc _ bool) = return (Yaml.Bool bool) -cfgCmdSetValue (ConfigCmdSetInstallGhc _ bool) = +cfgCmdSetValue _ (ConfigCmdSetInstallGhc _ bool) = return (Yaml.Bool bool) cfgCmdSetOptionName :: ConfigCmdSet -> Text diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} @@ -5,12 +6,8 @@ module Stack.Constants (buildPlanDir - ,distDirFromDir - ,workDirFromDir - ,distRelativeDir + ,buildPlanCacheDir ,haskellModuleExts - ,imageStagingDir - ,projectDockerSandboxDir ,stackDotYaml ,stackWorkEnvVar ,stackRootEnvVar @@ -18,11 +15,6 @@ ,deprecatedStackRootOptionName ,inContainerEnvVar ,inNixShellEnvVar - ,configCacheFile - ,configCabalMod - ,buildCacheFile - ,testSuccessFile - ,testBuiltFile ,stackProgName ,stackProgNameUpper ,wiredInPackages @@ -30,31 +22,24 @@ ,cabalPackageName ,implicitGlobalProjectDirDeprecated ,implicitGlobalProjectDir - ,hpcRelativeDir - ,hpcDirFromDir - ,objectInterfaceDirL - ,templatesDir ,defaultUserConfigPathDeprecated ,defaultUserConfigPath ,defaultGlobalConfigPathDeprecated ,defaultGlobalConfigPath ,platformVariantEnvVar ,compilerOptionsCabalFlag + ,ghcColorForceFlag + ,minTerminalWidth + ,maxTerminalWidth + ,defaultTerminalWidth ) where -import Control.Monad.Catch (MonadThrow) -import Control.Monad.Reader import Data.Char (toUpper) -import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet -import Data.Text (Text) -import Lens.Micro (Getting) import Path as FL -import Prelude +import Stack.Prelude import Stack.Types.Compiler -import Stack.Types.Config -import Stack.Types.PackageIdentifier import Stack.Types.PackageName -- | Extensions for anything that can be a Haskell module. @@ -69,127 +54,6 @@ haskellPreprocessorExts :: [Text] haskellPreprocessorExts = ["gc", "chs", "hsc", "x", "y", "ly", "cpphs"] --- | Output .o/.hi directory. -objectInterfaceDirL :: HasBuildConfig env => Getting r env (Path Abs Dir) -objectInterfaceDirL = to $ \env -> -- FIXME is this idomatic lens code? - let workDir = view workDirL env - root = view projectRootL env - in root workDir $(mkRelDir "odir/") - --- | The filename used for dirtiness check of source files. -buildCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) - => Path Abs Dir -- ^ Package directory. - -> m (Path Abs File) -buildCacheFile dir = - liftM - ( $(mkRelFile "stack-build-cache")) - (distDirFromDir dir) - --- | The filename used to mark tests as having succeeded -testSuccessFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) - => Path Abs Dir -- ^ Package directory - -> m (Path Abs File) -testSuccessFile dir = - liftM - ( $(mkRelFile "stack-test-success")) - (distDirFromDir dir) - --- | The filename used to mark tests as having built -testBuiltFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) - => Path Abs Dir -- ^ Package directory - -> m (Path Abs File) -testBuiltFile dir = - liftM - ( $(mkRelFile "stack-test-built")) - (distDirFromDir dir) - --- | The filename used for dirtiness check of config. -configCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) - => Path Abs Dir -- ^ Package directory. - -> m (Path Abs File) -configCacheFile dir = - liftM - ( $(mkRelFile "stack-config-cache")) - (distDirFromDir dir) - --- | The filename used for modification check of .cabal -configCabalMod :: (MonadThrow m, MonadReader env m, HasEnvConfig env) - => Path Abs Dir -- ^ Package directory. - -> m (Path Abs File) -configCabalMod dir = - liftM - ( $(mkRelFile "stack-cabal-mod")) - (distDirFromDir dir) - --- | Directory for HPC work. -hpcDirFromDir - :: (MonadThrow m, MonadReader env m, HasEnvConfig env) - => Path Abs Dir -- ^ Package directory. - -> m (Path Abs Dir) -hpcDirFromDir fp = - liftM (fp ) hpcRelativeDir - --- | Relative location of directory for HPC work. -hpcRelativeDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) - => m (Path Rel Dir) -hpcRelativeDir = - liftM ( $(mkRelDir "hpc")) distRelativeDir - --- | Package's build artifacts directory. -distDirFromDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) - => Path Abs Dir - -> m (Path Abs Dir) -distDirFromDir fp = - liftM (fp ) distRelativeDir - --- | Package's working directory. -workDirFromDir :: (MonadReader env m, HasEnvConfig env) - => Path Abs Dir - -> m (Path Abs Dir) -workDirFromDir fp = view $ workDirL.to (fp ) - --- | Directory for project templates. -templatesDir :: Config -> Path Abs Dir -templatesDir config = configStackRoot config $(mkRelDir "templates") - --- | Relative location of build artifacts. -distRelativeDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) - => m (Path Rel Dir) -distRelativeDir = do - cabalPkgVer <- view cabalVersionL - platform <- platformGhcRelDir - wc <- view $ actualCompilerVersionL.to whichCompiler - -- Cabal version, suffixed with "_ghcjs" if we're using GHCJS. - envDir <- - parseRelDir $ - (if wc == Ghcjs then (++ "_ghcjs") else id) $ - packageIdentifierString $ - PackageIdentifier cabalPackageName cabalPkgVer - platformAndCabal <- useShaPathOnWindows (platform envDir) - workDir <- view workDirL - return $ - workDir - $(mkRelDir "dist") - platformAndCabal - --- | Docker sandbox from project root. -projectDockerSandboxDir :: (MonadReader env m, HasConfig env) - => Path Abs Dir -- ^ Project root - -> m (Path Abs Dir) -- ^ Docker sandbox -projectDockerSandboxDir projectRoot = do - workDir <- view workDirL - return $ projectRoot workDir $(mkRelDir "docker/") - --- | Image staging dir from project root. -imageStagingDir :: (MonadReader env m, HasConfig env, MonadThrow m) - => Path Abs Dir -- ^ Project root - -> Int -- ^ Index of image - -> m (Path Abs Dir) -- ^ Docker sandbox -imageStagingDir projectRoot imageIdx = do - workDir <- view workDirL - idxRelDir <- parseRelDir (show imageIdx) - return $ projectRoot workDir $(mkRelDir "image") idxRelDir - -- | Name of the 'stack' program, uppercased stackProgNameUpper :: String stackProgNameUpper = map toUpper stackProgName @@ -231,7 +95,7 @@ -- although we already have STACK_IN_NIX_EXTRA_ARGS that is set in the same conditions, -- it can happen that STACK_IN_NIX_EXTRA_ARGS is set to empty. inNixShellEnvVar :: String -inNixShellEnvVar = map toUpper stackProgName ++ "_IN_NIXSHELL" +inNixShellEnvVar = map toUpper stackProgName ++ "_IN_NIX_SHELL" -- See https://downloads.haskell.org/~ghc/7.10.1/docs/html/libraries/ghc/src/Module.html#integerPackageKey wiredInPackages :: HashSet PackageName @@ -343,6 +207,12 @@ -> Path Abs Dir buildPlanDir = ( $(mkRelDir "build-plan")) +-- | Path where binary caches of the build plans are stored. +buildPlanCacheDir + :: Path Abs Dir -- ^ Stack root + -> Path Abs Dir +buildPlanCacheDir = ( $(mkRelDir "build-plan-cache")) + -- | Environment variable that stores a variant to append to platform-specific directory -- names. Used to ensure incompatible binaries aren't shared between Docker builds and host platformVariantEnvVar :: String @@ -353,3 +223,21 @@ compilerOptionsCabalFlag :: WhichCompiler -> String compilerOptionsCabalFlag Ghc = "--ghc-options" compilerOptionsCabalFlag Ghcjs = "--ghcjs-options" + +-- | The flag to pass to GHC when we want to force its output to be +-- colorized. +ghcColorForceFlag :: String +ghcColorForceFlag = "-fdiagnostics-color=always" + +-- | The minimum allowed terminal width. Used for pretty-printing. +minTerminalWidth :: Int +minTerminalWidth = 40 + +-- | The maximum allowed terminal width. Used for pretty-printing. +maxTerminalWidth :: Int +maxTerminalWidth = 200 + +-- | The default terminal width. Used for pretty-printing when we can't +-- automatically detect it and when the user doesn't supply one. +defaultTerminalWidth :: Int +defaultTerminalWidth = 100 diff --git a/src/Stack/Constants.hs-boot b/src/Stack/Constants.hs-boot deleted file mode 100644 --- a/src/Stack/Constants.hs-boot +++ /dev/null @@ -1,3 +0,0 @@ -module Stack.Constants where - -stackProgName :: String diff --git a/src/Stack/Constants/Config.hs b/src/Stack/Constants/Config.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Constants/Config.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +module Stack.Constants.Config + ( distDirFromDir + , workDirFromDir + , distRelativeDir + , imageStagingDir + , projectDockerSandboxDir + , configCacheFile + , configCabalMod + , buildCacheFile + , testSuccessFile + , testBuiltFile + , hpcRelativeDir + , hpcDirFromDir + , objectInterfaceDirL + , templatesDir + ) where + +import Stack.Prelude +import Stack.Constants +import Stack.Types.Compiler +import Stack.Types.Config +import Stack.Types.PackageIdentifier +import Path + +-- | Output .o/.hi directory. +objectInterfaceDirL :: HasBuildConfig env => Getting r env (Path Abs Dir) +objectInterfaceDirL = to $ \env -> -- FIXME is this idomatic lens code? + let workDir = view workDirL env + root = view projectRootL env + in root workDir $(mkRelDir "odir/") + +-- | The filename used for dirtiness check of source files. +buildCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) + => Path Abs Dir -- ^ Package directory. + -> m (Path Abs File) +buildCacheFile dir = + liftM + ( $(mkRelFile "stack-build-cache")) + (distDirFromDir dir) + +-- | The filename used to mark tests as having succeeded +testSuccessFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) + => Path Abs Dir -- ^ Package directory + -> m (Path Abs File) +testSuccessFile dir = + liftM + ( $(mkRelFile "stack-test-success")) + (distDirFromDir dir) + +-- | The filename used to mark tests as having built +testBuiltFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) + => Path Abs Dir -- ^ Package directory + -> m (Path Abs File) +testBuiltFile dir = + liftM + ( $(mkRelFile "stack-test-built")) + (distDirFromDir dir) + +-- | The filename used for dirtiness check of config. +configCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) + => Path Abs Dir -- ^ Package directory. + -> m (Path Abs File) +configCacheFile dir = + liftM + ( $(mkRelFile "stack-config-cache")) + (distDirFromDir dir) + +-- | The filename used for modification check of .cabal +configCabalMod :: (MonadThrow m, MonadReader env m, HasEnvConfig env) + => Path Abs Dir -- ^ Package directory. + -> m (Path Abs File) +configCabalMod dir = + liftM + ( $(mkRelFile "stack-cabal-mod")) + (distDirFromDir dir) + +-- | Directory for HPC work. +hpcDirFromDir + :: (MonadThrow m, MonadReader env m, HasEnvConfig env) + => Path Abs Dir -- ^ Package directory. + -> m (Path Abs Dir) +hpcDirFromDir fp = + liftM (fp ) hpcRelativeDir + +-- | Relative location of directory for HPC work. +hpcRelativeDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) + => m (Path Rel Dir) +hpcRelativeDir = + liftM ( $(mkRelDir "hpc")) distRelativeDir + +-- | Package's build artifacts directory. +distDirFromDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) + => Path Abs Dir + -> m (Path Abs Dir) +distDirFromDir fp = + liftM (fp ) distRelativeDir + +-- | Package's working directory. +workDirFromDir :: (MonadReader env m, HasEnvConfig env) + => Path Abs Dir + -> m (Path Abs Dir) +workDirFromDir fp = view $ workDirL.to (fp ) + +-- | Directory for project templates. +templatesDir :: Config -> Path Abs Dir +templatesDir config = configStackRoot config $(mkRelDir "templates") + +-- | Relative location of build artifacts. +distRelativeDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) + => m (Path Rel Dir) +distRelativeDir = do + cabalPkgVer <- view cabalVersionL + platform <- platformGhcRelDir + wc <- view $ actualCompilerVersionL.to whichCompiler + -- Cabal version, suffixed with "_ghcjs" if we're using GHCJS. + envDir <- + parseRelDir $ + (if wc == Ghcjs then (++ "_ghcjs") else id) $ + packageIdentifierString $ + PackageIdentifier cabalPackageName cabalPkgVer + platformAndCabal <- useShaPathOnWindows (platform envDir) + workDir <- view workDirL + return $ + workDir + $(mkRelDir "dist") + platformAndCabal + +-- | Docker sandbox from project root. +projectDockerSandboxDir :: (MonadReader env m, HasConfig env) + => Path Abs Dir -- ^ Project root + -> m (Path Abs Dir) -- ^ Docker sandbox +projectDockerSandboxDir projectRoot = do + workDir <- view workDirL + return $ projectRoot workDir $(mkRelDir "docker/") + +-- | Image staging dir from project root. +imageStagingDir :: (MonadReader env m, HasConfig env, MonadThrow m) + => Path Abs Dir -- ^ Project root + -> Int -- ^ Index of image + -> m (Path Abs Dir) -- ^ Docker sandbox +imageStagingDir projectRoot imageIdx = do + workDir <- view workDirL + idxRelDir <- parseRelDir (show imageIdx) + return $ projectRoot workDir $(mkRelDir "image") idxRelDir diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -16,35 +17,20 @@ , generateHpcMarkupIndex ) where -import Control.Exception.Safe (handleIO) -import Control.Exception.Lifted -import Control.Monad (liftM, when, unless, void, (<=<)) -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Trans.Resource +import Stack.Prelude import qualified Data.ByteString.Char8 as S8 -import Data.Foldable (forM_, asum, toList) -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.String -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT -import Data.Traversable (forM) import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO -import Prelude hiding (FilePath, writeFile) -import Stack.Build.Source (parseTargetsFromBuildOpts) import Stack.Build.Target import Stack.Config (getLocalPackages) -import Stack.Constants +import Stack.Constants.Config import Stack.Package import Stack.PrettyPrint import Stack.Types.Compiler @@ -52,8 +38,7 @@ import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT (StackM) -import Stack.Types.StringError +import Stack.Types.Runner import Stack.Types.Version import System.FilePath (isPathSeparator) import System.Process.Read @@ -62,38 +47,35 @@ import Web.Browser (openBrowser) -- | Invoked at the beginning of running with "--coverage" -deleteHpcReports :: (StackM env m, HasEnvConfig env) - => m () +deleteHpcReports :: HasEnvConfig env => RIO env () deleteHpcReports = do hpcDir <- hpcReportDir - ignoringAbsence (removeDirRecur hpcDir) + liftIO $ ignoringAbsence (removeDirRecur hpcDir) -- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is -- present. -updateTixFile :: (StackM env m, HasEnvConfig env) - => PackageName -> Path Abs File -> String -> m () +updateTixFile :: HasEnvConfig env => PackageName -> Path Abs File -> String -> RIO env () updateTixFile pkgName tixSrc testName = do exists <- doesFileExist tixSrc when exists $ do tixDest <- tixFilePath pkgName testName - ignoringAbsence (removeFile tixDest) + liftIO $ ignoringAbsence (removeFile tixDest) ensureDir (parent tixDest) -- Remove exe modules because they are problematic. This could be revisited if there's a GHC -- version that fixes https://ghc.haskell.org/trac/ghc/ticket/1853 mtix <- readTixOrLog tixSrc case mtix of - Nothing -> $logError $ "Failed to read " <> T.pack (toFilePath tixSrc) + Nothing -> logError $ "Failed to read " <> T.pack (toFilePath tixSrc) Just tix -> do liftIO $ writeTix (toFilePath tixDest) (removeExeModules tix) -- TODO: ideally we'd do a file move, but IIRC this can -- have problems. Something about moving between drives -- on windows? copyFile tixSrc =<< parseAbsFile (toFilePath tixDest ++ ".premunging") - ignoringAbsence (removeFile tixSrc) + liftIO $ ignoringAbsence (removeFile tixSrc) -- | Get the directory used for hpc reports for the given pkgId. -hpcPkgPath :: (StackM env m, HasEnvConfig env) - => PackageName -> m (Path Abs Dir) +hpcPkgPath :: HasEnvConfig env => PackageName -> RIO env (Path Abs Dir) hpcPkgPath pkgName = do outputDir <- hpcReportDir pkgNameRel <- parseRelDir (packageNameString pkgName) @@ -101,16 +83,16 @@ -- | Get the tix file location, given the name of the file (without extension), and the package -- identifier string. -tixFilePath :: (StackM env m, HasEnvConfig env) - => PackageName -> String -> m (Path Abs File) +tixFilePath :: HasEnvConfig env + => PackageName -> String -> RIO env (Path Abs File) tixFilePath pkgName testName = do pkgPath <- hpcPkgPath pkgName tixRel <- parseRelFile (testName ++ "/" ++ testName ++ ".tix") return (pkgPath tixRel) -- | Generates the HTML coverage report and shows a textual coverage summary for a package. -generateHpcReport :: (StackM env m, HasEnvConfig env) - => Path Abs Dir -> Package -> [Text] -> m () +generateHpcReport :: HasEnvConfig env + => Path Abs Dir -> Package -> [Text] -> RIO env () generateHpcReport pkgDir package tests = do compilerVersion <- view actualCompilerVersionL -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See @@ -118,11 +100,15 @@ let pkgName = packageNameText (packageName package) pkgId = packageIdentifierString (packageIdentifier package) ghcVersion = getGhcVersion compilerVersion + hasLibrary = + case packageLibraries package of + NoLibraries -> False + HasLibraries _ -> True eincludeName <- -- Pre-7.8 uses plain PKG-version in tix files. if ghcVersion < $(mkVersion "7.10") then return $ Right $ Just pkgId -- We don't expect to find a package key if there is no library. - else if not (packageHasLibrary package) then return $ Right Nothing + else if not hasLibrary then return $ Right Nothing -- Look in the inplace DB for the package key. -- See https://github.com/commercialhaskell/stack/issues/1181#issuecomment-148968986 else do @@ -132,7 +118,7 @@ eincludeName <- findPackageFieldForBuiltPackage pkgDir (packageIdentifier package) hpcNameField case eincludeName of Left err -> do - $logError err + logError err return $ Left err Right includeName -> return $ Right $ Just $ T.unpack includeName forM_ tests $ \testName -> do @@ -148,16 +134,17 @@ Just includeName -> ["--include", includeName ++ ":"] Nothing -> [] mreportPath <- generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs - forM_ mreportPath (displayReportPath report) + forM_ mreportPath (displayReportPath report . display) -generateHpcReportInternal :: (StackM env m, HasEnvConfig env) - => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String] -> m (Maybe (Path Abs File)) +generateHpcReportInternal :: HasEnvConfig env + => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String] + -> RIO env (Maybe (Path Abs File)) generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArgs = do -- If a .tix file exists, move it to the HPC output directory and generate a report for it. tixFileExists <- doesFileExist tixSrc if not tixFileExists then do - $logError $ T.concat + logError $ T.concat [ "Didn't find .tix for " , report , " - expected to find it at " @@ -167,21 +154,21 @@ return Nothing else (`catch` \err -> do let msg = show (err :: ReadProcessException) - $logError (T.pack msg) + logError (T.pack msg) generateHpcErrorReport reportDir $ sanitize msg return Nothing) $ - (`onException` $logError ("Error occurred while producing " <> report)) $ do + (`onException` logError ("Error occurred while producing " <> report)) $ do -- Directories for .mix files. hpcRelDir <- hpcRelativeDir -- Compute arguments used for both "hpc markup" and "hpc report". - pkgDirs <- liftM Map.keys getLocalPackages + pkgDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages let args = -- Use index files from all packages (allows cross-package coverage results). concatMap (\x -> ["--srcdir", toFilePathNoTrailingSep x]) pkgDirs ++ -- Look for index files in the correct dir (relative to each pkgdir). ["--hpcdir", toFilePathNoTrailingSep hpcRelDir, "--reset-hpcdirs"] menv <- getMinimalEnvOverride - $logInfo $ "Generating " <> report + logInfo $ "Generating " <> report outputLines <- liftM (map (S8.filter (/= '\r')) . S8.lines) $ readProcessStdout Nothing menv "hpc" ( "report" @@ -202,13 +189,13 @@ , " the hpc program. Please report this issue if you think" , " your coverage report should have meaningful results." ] - $logError (msg False) + logError (msg False) generateHpcErrorReport reportDir (msg True) return Nothing else do let reportPath = reportDir $(mkRelFile "hpc_index.html") -- Print output, stripping @\r@ characters because Windows. - forM_ outputLines ($logInfo . T.decodeUtf8) + forM_ outputLines (logInfo . T.decodeUtf8) -- Generate the markup. void $ readProcessStdout Nothing menv "hpc" ( "markup" @@ -225,8 +212,8 @@ , hroptsOpenBrowser :: Bool } deriving (Show) -generateHpcReportForTargets :: (StackM env m, HasEnvConfig env) - => HpcReportOpts -> m () +generateHpcReportForTargets :: HasEnvConfig env + => HpcReportOpts -> RIO env () generateHpcReportForTargets opts = do let (tixFiles, targetNames) = partition (".tix" `T.isSuffixOf`) (hroptsInputs opts) targetTixFiles <- @@ -236,20 +223,18 @@ then return [] else do when (hroptsAll opts && not (null targetNames)) $ - $logWarn $ "Since --all is used, it is redundant to specify these targets: " <> T.pack (show targetNames) - (_,_,targets) <- parseTargetsFromBuildOpts + logWarn $ "Since --all is used, it is redundant to specify these targets: " <> T.pack (show targetNames) + (_,_,targets) <- parseTargets AllowNoTargets defaultBuildOptsCLI { boptsCLITargets = if hroptsAll opts then [] else targetNames } liftM concat $ forM (Map.toList targets) $ \(name, target) -> case target of - STUnknown -> throwString $ - "Error: " ++ packageNameString name ++ " isn't a known local page" - STNonLocal -> throwString $ + TargetAll Dependency -> throwString $ "Error: Expected a local package, but " ++ packageNameString name ++ " is either an extra-dep or in the snapshot." - STLocalComps comps -> do + TargetComps comps -> do pkgPath <- hpcPkgPath name forM (toList comps) $ \nc -> case nc of @@ -259,7 +244,7 @@ "Can't specify anything except test-suites as hpc report targets (" ++ packageNameString name ++ " is used with a non test-suite target)" - STLocalAll -> do + TargetAll ProjectPackage -> do pkgPath <- hpcPkgPath name exists <- doesDirExist pkgPath if exists @@ -284,12 +269,11 @@ forM_ mreportPath $ \reportPath -> if hroptsOpenBrowser opts then do - $prettyInfo $ "Opening" <+> display reportPath <+> "in the browser." + prettyInfo $ "Opening" <+> display reportPath <+> "in the browser." void $ liftIO $ openBrowser (toFilePath reportPath) - else displayReportPath report reportPath + else displayReportPath report (display reportPath) -generateHpcUnifiedReport :: (StackM env m, HasEnvConfig env) - => m () +generateHpcUnifiedReport :: HasEnvConfig env => RIO env () generateHpcUnifiedReport = do outputDir <- hpcReportDir ensureDir outputDir @@ -303,7 +287,7 @@ let tixFiles = tixFiles0 ++ extraTixFiles 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) @@ -312,14 +296,15 @@ else do let report = "unified report" mreportPath <- generateUnionReport report reportDir tixFiles - forM_ mreportPath (displayReportPath report) + forM_ mreportPath (displayReportPath report . display) -generateUnionReport :: (StackM env m, HasEnvConfig env) - => Text -> Path Abs Dir -> [Path Abs File] -> m (Maybe (Path Abs File)) +generateUnionReport :: HasEnvConfig env + => Text -> Path Abs Dir -> [Path Abs File] + -> RIO env (Maybe (Path Abs File)) generateUnionReport report reportDir tixFiles = do (errs, tix) <- fmap (unionTixes . map removeExeModules) (mapMaybeM readTixOrLog tixFiles) - $logDebug $ "Using the following tix files: " <> T.pack (show tixFiles) - unless (null errs) $ $logWarn $ T.concat $ + logDebug $ "Using the following tix files: " <> T.pack (show tixFiles) + 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") @@ -327,13 +312,13 @@ liftIO $ writeTix (toFilePath tixDest) tix generateHpcReportInternal tixDest reportDir report [] [] -readTixOrLog :: (MonadLogger m, MonadIO m, MonadBaseControl IO m) => Path b File -> m (Maybe Tix) +readTixOrLog :: (MonadLogger m, MonadUnliftIO m) => Path b File -> m (Maybe Tix) readTixOrLog path = do - mtix <- liftIO (readTix (toFilePath path)) `catch` \errorCall -> do - $logError $ "Error while reading tix: " <> T.pack (show (errorCall :: ErrorCall)) + mtix <- liftIO (readTix (toFilePath path)) `catchAny` \errorCall -> do + logError $ "Error while reading tix: " <> T.pack (show errorCall) return Nothing when (isNothing mtix) $ - $logError $ "Failed to read tix file " <> T.pack (toFilePath path) + logError $ "Failed to read tix file " <> T.pack (toFilePath path) return mtix -- | Module names which contain '/' have a package name, and so they weren't built into the @@ -351,8 +336,7 @@ | hash1 == hash2 && len1 == len2 = Right (TixModule k hash1 len1 (zipWith (+) tix1 tix2)) merge _ _ = Left () -generateHpcMarkupIndex :: (StackM env m, HasEnvConfig env) - => m () +generateHpcMarkupIndex :: HasEnvConfig env => RIO env () generateHpcMarkupIndex = do outputDir <- hpcReportDir let outputFile = outputDir $(mkRelFile "index.html") @@ -364,7 +348,7 @@ let indexPath = subdir $(mkRelFile "hpc_index.html") exists' <- doesFileExist indexPath if not exists' then return Nothing else do - relPath <- stripDir outputDir indexPath + relPath <- stripProperPrefix outputDir indexPath let package = dirname dir testsuite = dirname subdir return $ Just $ T.concat @@ -402,7 +386,7 @@ [""]) ++ [""] unless (null rows) $ - $logInfo $ "\nAn index of the generated HTML coverage reports is available at " <> + logInfo $ "\nAn index of the generated HTML coverage reports is available at " <> T.pack (toFilePath outputFile) generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Text -> m () @@ -427,8 +411,9 @@ dirnameString = dropWhileEnd isPathSeparator . toFilePath . dirname findPackageFieldForBuiltPackage - :: (StackM env m, HasEnvConfig env) - => Path Abs Dir -> PackageIdentifier -> Text -> m (Either Text Text) + :: HasEnvConfig env + => Path Abs Dir -> PackageIdentifier -> Text + -> RIO env (Either Text Text) findPackageFieldForBuiltPackage pkgDir pkgId field = do distDir <- distDirFromDir pkgDir let inplaceDir = distDir $(mkRelDir "package.conf.inplace") @@ -443,14 +428,14 @@ if cabalVer < $(mkVersion "1.24") then do path <- liftM (inplaceDir ) $ parseRelFile (pkgIdStr ++ "-inplace.conf") - $logDebug $ "Parsing config in Cabal < 1.24 location: " <> T.pack (toFilePath path) + logDebug $ "Parsing config in Cabal < 1.24 location: " <> T.pack (toFilePath path) exists <- doesFileExist path if exists then extractField path else notFoundErr else do -- With Cabal-1.24, it's in a different location. - $logDebug $ "Scanning " <> T.pack (toFilePath inplaceDir) <> " for files matching " <> T.pack pkgIdStr + logDebug $ "Scanning " <> T.pack (toFilePath inplaceDir) <> " for files matching " <> T.pack pkgIdStr (_, files) <- handleIO (const $ return ([], [])) $ listDir inplaceDir - $logDebug $ T.pack (show files) + logDebug $ T.pack (show files) case mapMaybe (\file -> fmap (const file) . (T.stripSuffix ".conf" <=< T.stripPrefix (T.pack (pkgIdStr ++ "-"))) . T.pack . toFilePath . filename $ file) files of [] -> notFoundErr @@ -458,12 +443,12 @@ _ -> return $ Left $ "Multiple files matching " <> T.pack (pkgIdStr ++ "-*.conf") <> " found in " <> T.pack (toFilePath inplaceDir) <> ". Maybe try 'stack clean' on this package?" -displayReportPath :: (StackM env m, HasAnsiAnn (Ann a), Display a) - => Text -> a -> m () +displayReportPath :: (HasRunner env) + => Text -> AnsiDoc -> RIO env () displayReportPath report reportPath = - $prettyInfo $ "The" <+> fromString (T.unpack report) <+> "is available at" <+> display reportPath + prettyInfo $ "The" <+> fromString (T.unpack report) <+> "is available at" <+> reportPath -findExtraTixFiles :: (StackM env m , HasEnvConfig env) => m [Path Abs File] +findExtraTixFiles :: HasEnvConfig env => RIO env [Path Abs File] findExtraTixFiles = do outputDir <- hpcReportDir let dir = outputDir $(mkRelDir "extra-tix-files") diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP, ConstraintKinds, DeriveDataTypeable, FlexibleContexts, MultiWayIf, NamedFieldPuns, OverloadedStrings, PackageImports, RankNTypes, RecordWildCards, ScopedTypeVariables, TemplateHaskell, TupleSections #-} @@ -20,15 +21,7 @@ ,StackDockerException(..) ) where -import Control.Applicative -import Control.Concurrent.MVar.Lifted (MVar,modifyMVar_,newMVar) -import Control.Exception.Lifted -import Control.Monad -import Control.Monad.Catch (MonadThrow,throwM,MonadCatch) -import Control.Monad.IO.Class (MonadIO,liftIO) -import Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn) -import Control.Monad.Reader (MonadReader,runReaderT) -import Control.Monad.Trans.Control (MonadBaseControl) +import Stack.Prelude import Control.Monad.Writer (execWriter,runWriter,tell) import qualified Crypto.Hash as Hash (Digest, MD5, hash) import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode) @@ -37,14 +30,11 @@ 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,isPrefixOf,isInfixOf,foldl') +import Data.List (dropWhileEnd,intercalate,isPrefixOf,isInfixOf) import Data.List.Extra (trim, nubOrd) -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 import qualified Data.Text.Encoding as T import Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..)) @@ -54,16 +44,15 @@ import Path.Extra (toFilePathNoTrailingSep) import Path.IO hiding (canonicalizePath) import qualified Paths_stack as Meta -import Prelude -- Fix redundant import warnings import Stack.Config (getInContainer) import Stack.Constants +import Stack.Constants.Config import Stack.Docker.GlobalDB import Stack.Types.PackageIndex +import Stack.Types.Runner import Stack.Types.Version import Stack.Types.Config import Stack.Types.Docker -import Stack.Types.Internal -import Stack.Types.StackT import Stack.Setup (ensureDockerStackExe) import System.Directory (canonicalizePath,getHomeDirectory) import System.Environment (getEnv,getEnvironment,getProgName,getArgs,getExecutablePath) @@ -82,7 +71,6 @@ #ifndef WINDOWS import Control.Concurrent (threadDelay) -import qualified Control.Monad.Trans.Control as Control import System.Posix.Signals import qualified System.Posix.User as PosixUser #endif @@ -91,17 +79,17 @@ -- Otherwise, runs the inner action. -- -- This takes an optional release action which should be taken IFF control is --- transfering away from the current process to the intra-container one. The main use +-- transferring away from the current process to the intra-container one. The main use -- for this is releasing a lock. After launching reexecution, the host process becomes -- nothing but an manager for the call into docker and thus may not hold the lock. reexecWithOptionalContainer - :: (StackM env m, HasConfig env) + :: HasConfig env => Maybe (Path Abs Dir) - -> Maybe (m ()) + -> Maybe (RIO env ()) -> IO () - -> Maybe (m ()) - -> Maybe (m ()) - -> m () + -> Maybe (RIO env ()) + -> Maybe (RIO env ()) + -> RIO env () reexecWithOptionalContainer mprojectRoot = execWithOptionalContainer mprojectRoot getCmdArgs where @@ -129,7 +117,7 @@ | configPlatform config == dockerContainerPlatform -> do exePath <- liftIO getExecutablePath cmdArgs args exePath - | otherwise -> throwM UnsupportedStackExeHostPlatformException + | otherwise -> throwIO UnsupportedStackExeHostPlatformException Just DockerStackExeImage -> do progName <- liftIO getProgName return (FP.takeBaseName progName, args, [], []) @@ -197,20 +185,20 @@ -- -- This takes an optional release action just like `reexecWithOptionalContainer`. execWithOptionalContainer - :: (StackM env m, HasConfig env) + :: HasConfig env => Maybe (Path Abs Dir) - -> GetCmdArgs env m - -> Maybe (m ()) + -> GetCmdArgs env + -> Maybe (RIO env ()) -> IO () - -> Maybe (m ()) - -> Maybe (m ()) - -> m () + -> Maybe (RIO env ()) + -> Maybe (RIO env ()) + -> RIO env () execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease = do config <- view configL inContainer <- getInContainer isReExec <- view reExecL if | inContainer && not isReExec && (isJust mbefore || isJust mafter) -> - throwM OnlyOnHostException + throwIO OnlyOnHostException | inContainer -> liftIO (do inner exitSuccess) @@ -231,20 +219,21 @@ fromMaybeAction (Just hook) = hook -- | Error if running in a container. -preventInContainer :: (MonadIO m,MonadThrow m) => m () -> m () +preventInContainer :: MonadIO m => m () -> m () preventInContainer inner = do inContainer <- getInContainer if inContainer - then throwM OnlyOnHostException + then throwIO OnlyOnHostException else inner -- | Run a command in a new Docker container, then exit the process. -runContainerAndExit :: (StackM env m, HasConfig env) - => GetCmdArgs env m +runContainerAndExit + :: HasConfig env + => GetCmdArgs env -> Maybe (Path Abs Dir) -- ^ Project root (maybe) - -> m () -- ^ Action to run before - -> m () -- ^ Action to run after - -> m () + -> RIO env () -- ^ Action to run before + -> RIO env () -- ^ Action to run after + -> RIO env () runContainerAndExit getCmdArgs mprojectRoot before @@ -270,7 +259,7 @@ image = dockerImage docker when (isRemoteDocker && maybe False (isInfixOf "boot2docker") dockerCertPath) - ($logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.") + (logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.") maybeImageInfo <- inspect envOverride image imageInfo@Inspect{..} <- case maybeImageInfo of Just ii -> return ii @@ -364,9 +353,9 @@ ,args]) before #ifndef WINDOWS - runInBase <- Control.liftBaseWith $ \run -> return (void . run) + run <- askRunInIO oldHandlers <- forM [sigINT,sigABRT,sigHUP,sigPIPE,sigTERM,sigUSR1,sigUSR2] $ \sig -> do - let sigHandler = runInBase $ do + let sigHandler = run $ do readProcessNull Nothing envOverride "docker" ["kill","--signal=" ++ show sig,containerID] when (sig `elem` [sigTERM,sigABRT]) $ do @@ -414,8 +403,7 @@ sshRelDir = $(mkRelDir ".ssh/") -- | Clean-up old docker images and containers. -cleanup :: (StackM env m, HasConfig env) - => CleanupOpts -> m () +cleanup :: HasConfig env => CleanupOpts -> RIO env () cleanup opts = do config <- view configL let docker = configDocker config @@ -474,16 +462,16 @@ [] -> return () (c:_):t:v:_ -> do args <- if | toUpper c == 'R' && t == imageStr -> - do $logInfo (concatT ["Removing image: '",v,"'"]) + do logInfo (concatT ["Removing image: '",v,"'"]) return ["rmi",v] | toUpper c == 'R' && t == containerStr -> - do $logInfo (concatT ["Removing container: '",v,"'"]) + do logInfo (concatT ["Removing container: '",v,"'"]) return ["rm","-f",v] | otherwise -> throwM (InvalidCleanupCommandException line) e <- try (readDockerProcess envOverride Nothing args) case e of Left ex@ProcessFailed{} -> - $logError (concatT ["Could not remove: '",v,"': ", show ex]) + logError (concatT ["Could not remove: '",v,"': ", show ex]) Left e' -> throwM e' Right _ -> return () _ -> throwM (InvalidCleanupCommandException line) @@ -495,12 +483,12 @@ | repo == "" -> (hash,[]) | tag == "" -> (hash,[repo]) | otherwise -> (hash,[repo ++ ":" ++ tag]) - _ -> throw (InvalidImagesOutputException line) + _ -> impureThrow (InvalidImagesOutputException line) parseContainersOut = map parseContainer . drop 1 . lines . decodeUtf8 where parseContainer line = case words line of - hash:image:rest -> (hash,(image,last rest)) - _ -> throw (InvalidPSOutputException line) + hash:image:rest | last:_ <- reverse rest -> (hash,(image,last)) + _ -> impureThrow (InvalidPSOutputException line) buildPlan curTime imagesLastUsed imageRepos @@ -641,17 +629,17 @@ containerStr = "container" -- | Inspect Docker image or container. -inspect :: (MonadIO m,MonadLogger m,MonadBaseControl IO m,MonadCatch m) +inspect :: (MonadUnliftIO m,MonadLogger m) => EnvOverride -> String -> m (Maybe Inspect) inspect envOverride image = do results <- inspects envOverride [image] case Map.toList results of [] -> return Nothing [(_,i)] -> return (Just i) - _ -> throwM (InvalidInspectOutputException "expect a single result") + _ -> throwIO (InvalidInspectOutputException "expect a single result") -- | Inspect multiple Docker images and/or containers. -inspects :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +inspects :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> [String] -> m (Map String Inspect) inspects _ [] = return Map.empty inspects envOverride images = @@ -661,14 +649,15 @@ Right inspectOut -> -- filtering with 'isAscii' to workaround @docker inspect@ output containing invalid UTF-8 case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of - Left msg -> throwM (InvalidInspectOutputException msg) + Left msg -> throwIO (InvalidInspectOutputException msg) Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results)) Left (ProcessFailed _ _ _ err) - | "Error: No such image" `LBS.isPrefixOf` err -> return Map.empty - Left e -> throwM e + | any (`LBS.isPrefixOf` err) missingImagePrefixes -> return Map.empty + Left e -> throwIO e + where missingImagePrefixes = ["Error: No such image", "Error: No such object:"] -- | Pull latest version of configured Docker image from registry. -pull :: (StackM env m, HasConfig env) => m () +pull :: HasConfig env => RIO env () pull = do config <- view configL let docker = configDocker config @@ -680,9 +669,9 @@ pullImage :: (MonadLogger m,MonadIO m,MonadThrow m) => EnvOverride -> DockerOpts -> String -> m () pullImage envOverride docker image = - do $logInfo (concatT ["Pulling image from registry: '",image,"'"]) + do logInfo (concatT ["Pulling image from registry: '",image,"'"]) when (dockerRegistryLogin docker) - (do $logInfo "You may need to log in." + (do logInfo "You may need to log in." callProcess $ Cmd Nothing "docker" @@ -706,30 +695,30 @@ ec <- liftIO (waitForProcess ph) case ec of ExitSuccess -> return () - ExitFailure _ -> throwM (PullFailedException image) + ExitFailure _ -> throwIO (PullFailedException image) -- | Check docker version (throws exception if incorrect) checkDockerVersion - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> DockerOpts -> m () checkDockerVersion envOverride docker = do dockerExists <- doesExecutableExist envOverride "docker" - unless dockerExists (throwM DockerNotInstalledException) + unless dockerExists (throwIO DockerNotInstalledException) dockerVersionOut <- readDockerProcess envOverride Nothing ["--version"] case words (decodeUtf8 dockerVersionOut) of (_:_:v:_) -> case parseVersionFromString (stripVersion v) of Just v' | v' < minimumDockerVersion -> - throwM (DockerTooOldException minimumDockerVersion v') + throwIO (DockerTooOldException minimumDockerVersion v') | v' `elem` prohibitedDockerVersions -> - throwM (DockerVersionProhibitedException prohibitedDockerVersions v') + throwIO (DockerVersionProhibitedException prohibitedDockerVersions v') | not (v' `withinRange` dockerRequireDockerVersion docker) -> - throwM (BadDockerVersionException (dockerRequireDockerVersion docker) v') + throwIO (BadDockerVersionException (dockerRequireDockerVersion docker) v') | otherwise -> return () - _ -> throwM InvalidVersionOutputException - _ -> throwM InvalidVersionOutputException + _ -> throwIO InvalidVersionOutputException + _ -> throwIO InvalidVersionOutputException where minimumDockerVersion = $(mkVersion "1.6.0") prohibitedDockerVersions = [] stripVersion v = takeWhile (/= '-') (dropWhileEnd (not . isDigit) v) @@ -747,14 +736,14 @@ -- | The Docker container "entrypoint": special actions performed when first entering -- a container, such as switching the UID/GID to the "outside-Docker" user's. -entrypoint :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m) +entrypoint :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) => Config -> DockerEntrypoint -> m () entrypoint config@Config{..} DockerEntrypoint{..} = modifyMVar_ entrypointMVar $ \alreadyRan -> do -- Only run the entrypoint once unless alreadyRan $ do envOverride <- getEnvOverride configPlatform - homeDir <- parseAbsDir =<< liftIO (getEnv "HOME") + homeDir <- liftIO $ parseAbsDir =<< getEnv "HOME" -- Get the UserEntry for the 'stack' user in the image, if it exists estackUserEntry0 <- liftIO $ tryJust (guard . isDoesNotExistError) $ User.getUserEntryForName stackUserName @@ -768,7 +757,7 @@ Right ue -> do -- If the 'stack' user exists in the image, copy any build plans and package indices from -- its original home directory to the host's stack root, to avoid needing to download them - origStackHomeDir <- parseAbsDir (User.homeDirectory ue) + origStackHomeDir <- liftIO $ parseAbsDir (User.homeDirectory ue) let origStackRoot = origStackHomeDir $(mkRelDir ("." ++ stackProgName)) buildPlanDirExists <- doesDirExist (buildPlanDir origStackRoot) when buildPlanDirExists $ do @@ -863,9 +852,9 @@ -- | Produce a strict 'S.ByteString' from the stdout of a -- process. Throws a 'ReadProcessException' exception if the --- process fails. Logs process's stderr using @$logError@. +-- process fails. Logs process's stderr using @logError@. readDockerProcess - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> Maybe (Path Abs Dir) -> [String] -> m BS.ByteString readDockerProcess envOverride mpwd = readProcessStdout mpwd envOverride "docker" @@ -881,13 +870,13 @@ decodeUtf8 :: BS.ByteString -> String decodeUtf8 bs = T.unpack (T.decodeUtf8 bs) --- | Convenience function constructing message for @$log*@. +-- | Convenience function constructing message for @log*@. concatT :: [String] -> Text concatT = T.pack . concat -- | Fail with friendly error if project root not set. fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir -fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException) +fromMaybeProjectRoot = fromMaybe (impureThrow CannotDetermineProjectRootException) -- | Environment variable that contained the old sandbox ID. -- | Use of this variable is deprecated, and only used to detect old images. @@ -942,10 +931,9 @@ <*> fmap join (o .:? "Entrypoint") .!= [] -- | Function to get command and arguments to run in Docker container -type GetCmdArgs env m - = (StackM env m, HasConfig env) - => DockerOpts +type GetCmdArgs env + = DockerOpts -> EnvOverride -> Inspect -> Bool - -> m (FilePath,[String],[(String,String)],[Mount]) + -> RIO env (FilePath,[String],[(String,String)],[Mount]) diff --git a/src/Stack/Docker/GlobalDB.hs b/src/Stack/Docker/GlobalDB.hs --- a/src/Stack/Docker/GlobalDB.hs +++ b/src/Stack/Docker/GlobalDB.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, GADTs, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, NamedFieldPuns #-} @@ -15,24 +16,21 @@ ,DockerImageExeId) where -import Control.Exception (IOException,catch,throwIO) -import Control.Monad (forM_, when) import Control.Monad.Logger (NoLoggingT) -import Control.Monad.Trans.Resource (ResourceT) +import Stack.Prelude import Data.List (sortBy, isInfixOf, stripPrefix) import Data.List.Extra (stripSuffix) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.Time.Clock (UTCTime,getCurrentTime) import Database.Persist import Database.Persist.Sqlite import Database.Persist.TH -import Path (toFilePath, parent) +import Path (parent, (<.>)) import Path.IO (ensureDir) import Stack.Types.Config import Stack.Types.Docker -import Stack.Types.StringError +import System.FileLock (withFileLock, SharedExclusive(Exclusive)) share [mkPersist sqlSettings, mkMigrate "migrateTables"] [persistLowerCase| DockerImageProject @@ -101,10 +99,11 @@ withGlobalDB :: forall a. Config -> SqlPersistT (NoLoggingT (ResourceT IO)) a -> IO a withGlobalDB config action = do let db = dockerDatabasePath (configDocker config) + dbLock <- db <.> "lock" ensureDir (parent db) - runSqlite (T.pack (toFilePath db)) + withFileLock (toFilePath dbLock) Exclusive (\_fl -> runSqlite (T.pack (toFilePath db)) (do _ <- runMigrationSilent migrateTables - action) + action)) `catch` \ex -> do let str = show ex str' = fromMaybe str $ stripPrefix "user error (" $ diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} @@ -14,40 +15,32 @@ ,pruneGraph ) where -import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Monad (liftM, void) -import Control.Monad.IO.Class -import Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.Foldable as F import qualified Data.HashSet as HashSet -import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe -import Data.Monoid ((<>)) -import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified Data.Traversable as T +import Distribution.Text (display) import Distribution.License (License(BSD3)) -import Prelude -- Fix redundant import warnings import Stack.Build (withLoadPackage) import Stack.Build.Installed (getInstalled, GetInstalledOpts(..)) import Stack.Build.Source import Stack.Build.Target +import Stack.Config (getLocalPackages) import Stack.Constants import Stack.Package import Stack.PackageDump (DumpPackage(..)) +import Stack.Prelude import Stack.Types.Build +import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.GhcPkgId import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT import Stack.Types.Version -- | Options record for @stack dot@ @@ -80,9 +73,7 @@ } -- | Visualize the project's dependencies as a graphviz graph -dot :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) - => DotOpts - -> m () +dot :: HasEnvConfig env => DotOpts -> RIO env () dot dotOpts = do (localNames, prunedGraph) <- createPrunedDependencyGraph dotOpts printGraph dotOpts localNames prunedGraph @@ -98,12 +89,13 @@ -- | Create the dependency graph and also prune it as specified in the dot -- options. Returns a set of local names and and a map from package names to -- dependencies. -createPrunedDependencyGraph :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) +createPrunedDependencyGraph :: HasEnvConfig env => DotOpts - -> m (Set PackageName, + -> RIO env + (Set PackageName, Map PackageName (Set PackageName, DotPayload)) createPrunedDependencyGraph dotOpts = do - localNames <- liftM Map.keysSet getLocalPackageViews + localNames <- liftM (Map.keysSet . lpProject) getLocalPackages resultGraph <- createDependencyGraph dotOpts let pkgsToPrune = if dotIncludeBase dotOpts then dotPrune dotOpts @@ -115,11 +107,11 @@ -- name to a tuple of dependencies and payload if available. This -- function mainly gathers the required arguments for -- @resolveDependencies@. -createDependencyGraph :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) +createDependencyGraph :: HasEnvConfig env => DotOpts - -> m (Map PackageName (Set PackageName, DotPayload)) + -> RIO env (Map PackageName (Set PackageName, DotPayload)) createDependencyGraph dotOpts = do - (_, _, locals, _, _, sourceMap) <- loadSourceMapFull NeedTargets defaultBuildOptsCLI + (locals, sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI { boptsCLITargets = dotTargets dotOpts , boptsCLIFlags = dotFlags dotOpts } @@ -134,27 +126,26 @@ globalIdMap = Map.fromList $ map (\dp -> (dpGhcPkgId dp, dpPackageIdent dp)) globalDump withLoadPackage (\loader -> do let depLoader = createDepLoader sourceMap installedMap globalDumpMap globalIdMap loadPackageDeps - loadPackageDeps name version flags ghcOptions + loadPackageDeps name version loc flags ghcOptions -- Skip packages that can't be loaded - see -- https://github.com/commercialhaskell/stack/issues/2967 | name `elem` [$(mkPackageName "rts"), $(mkPackageName "ghc")] = return (Set.empty, DotPayload (Just version) (Just BSD3)) - | otherwise = fmap (packageAllDeps &&& makePayload) - (loader name version flags ghcOptions) + | otherwise = fmap (packageAllDeps &&& makePayload) (loader loc flags ghcOptions) liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader) where makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) -listDependencies :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) +listDependencies :: HasEnvConfig env => ListDepsOpts - -> m () + -> RIO env () listDependencies opts = do let dotOpts = listDepsDotOpts opts (_, resultGraph) <- createPrunedDependencyGraph dotOpts void (Map.traverseWithKey go (snd <$> resultGraph)) where go name payload = let payloadText = - if listDepsLicense opts - then maybe "" (Text.pack . show) (payloadLicense payload) + if listDepsLicense opts + then maybe "" (Text.pack . display) (payloadLicense payload) else maybe "" (Text.pack . show) (payloadVersion payload) line = packageNameText name <> listDepsSep opts <> payloadText in liftIO $ Text.putStrLn line @@ -215,17 +206,20 @@ -> Map PackageName (InstallLocation, Installed) -> Map PackageName (DumpPackage () () ()) -> Map GhcPkgId PackageIdentifier - -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> m (Set PackageName, DotPayload)) + -> (PackageName -> Version -> PackageLocationIndex FilePath -> + Map FlagName Bool -> [Text] -> m (Set PackageName, DotPayload)) -> PackageName -> m (Set PackageName, DotPayload) createDepLoader sourceMap installed globalDumpMap globalIdMap loadPackageDeps pkgName = if not (pkgName `HashSet.member` wiredInPackages) then case Map.lookup pkgName sourceMap of - Just (PSLocal lp) -> pure (packageAllDeps pkg, payloadFromLocal pkg) + Just (PSFiles lp _) -> pure (packageAllDeps pkg, payloadFromLocal pkg) where pkg = localPackageToPackage lp - Just (PSUpstream version _ flags ghcOptions _) -> - loadPackageDeps pkgName version flags ghcOptions + Just (PSIndex _ flags ghcOptions loc) -> + -- FIXME pretty certain this could be cleaned up a lot by including more info in PackageSource + let PackageIdentifierRevision (PackageIdentifier name version) _ = loc + in assert (pkgName == name) (loadPackageDeps pkgName version (PLIndex loc) flags ghcOptions) Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed)) -- For wired-in-packages, use information from ghc-pkg (see #3084) else case Map.lookup pkgName globalDumpMap of @@ -238,7 +232,10 @@ (dpDepends dp) where payloadFromLocal pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) - payloadFromInstalled maybePkg = DotPayload (fmap (installedVersion . snd) maybePkg) Nothing + payloadFromInstalled maybePkg = DotPayload (fmap (installedVersion . snd) maybePkg) $ + case maybePkg of + Just (_, Library _ _ mlicense) -> mlicense + _ -> Nothing payloadFromDump dp = DotPayload (Just $ packageIdentifierVersion $ dpPackageIdent dp) (dpLicense dp) -- | Resolve the direct (depth 0) external dependencies of the given local packages diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs --- a/src/Stack/Exec.hs +++ b/src/Stack/Exec.hs @@ -1,7 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -12,13 +11,10 @@ module Stack.Exec where -import Control.Monad.Reader -import Control.Monad.Logger -import Control.Monad.Trans.Control (MonadBaseControl) +import Stack.Prelude import Stack.Types.Config import System.Process.Log -import Control.Exception.Lifted import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import System.Exit import System.Process.Run (callProcess, callProcessObserveStdout, Cmd(..)) @@ -29,22 +25,30 @@ import System.Process.Read (EnvOverride, envHelper, preProcess) #endif --- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH +-- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH. +-- +-- Note that this also passes through the GHCRTS environment variable. +-- See https://github.com/commercialhaskell/stack/issues/3444 defaultEnvSettings :: EnvSettings defaultEnvSettings = EnvSettings { esIncludeLocals = True , esIncludeGhcPackagePath = True , esStackExe = True , esLocaleUtf8 = False + , esKeepGhcRts = True } -- | Environment settings which do not embellish the environment +-- +-- Note that this also passes through the GHCRTS environment variable. +-- See https://github.com/commercialhaskell/stack/issues/3444 plainEnvSettings :: EnvSettings plainEnvSettings = EnvSettings { esIncludeLocals = False , esIncludeGhcPackagePath = False , esStackExe = False , esLocaleUtf8 = False + , esKeepGhcRts = True } -- | Execute a process within the Stack configured environment. @@ -55,14 +59,14 @@ -- sub-process. This allows signals to be propagated (#527) -- -- 2) On windows, an 'ExitCode' exception will be thrown. -exec :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) +exec :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> String -> [String] -> m b #ifdef WINDOWS exec = execSpawn #else exec menv cmd0 args = do cmd <- preProcess Nothing menv cmd0 - $withProcessTimeLog cmd args $ + withProcessTimeLog cmd args $ liftIO $ PID1.run cmd args (envHelper menv) #endif @@ -70,19 +74,19 @@ -- is a sub-process, which is helpful in some cases (#1306) -- -- This function only exits by throwing 'ExitCode'. -execSpawn :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) +execSpawn :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> String -> [String] -> m b execSpawn menv cmd0 args = do - e <- $withProcessTimeLog cmd0 args $ + e <- withProcessTimeLog cmd0 args $ try (callProcess (Cmd Nothing cmd0 menv args)) liftIO $ case e of Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec Right () -> exitSuccess -execObserve :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) +execObserve :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> String -> [String] -> m String execObserve menv cmd0 args = do - e <- $withProcessTimeLog cmd0 args $ + e <- withProcessTimeLog cmd0 args $ try (callProcessObserveStdout (Cmd Nothing cmd0 menv args)) case e of Left (ProcessExitedUnsuccessfully _ ec) -> liftIO $ exitWith ec diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -8,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ViewPatterns #-} @@ -15,6 +18,7 @@ module Stack.Fetch ( unpackPackages + , unpackPackageIdent , unpackPackageIdents , fetchPackages , untar @@ -29,66 +33,46 @@ import qualified Codec.Archive.Tar.Check as Tar import qualified Codec.Archive.Tar.Entry as Tar import Codec.Compression.GZip (decompress) -import Control.Applicative -import Control.Concurrent.Async (Concurrently (..)) -import Control.Concurrent.MVar.Lifted (modifyMVar, newMVar) import Control.Concurrent.STM -import Control.Exception (assert) -import Control.Monad (join, liftM, unless, void, when) -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Reader (ask, runReaderT) -import Control.Monad.Trans.Control -import Control.Monad.Trans.Unlift (MonadBaseUnlift, askRunBase) +import Stack.Prelude import Crypto.Hash (SHA256 (..)) -import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.Either (partitionEithers) import qualified Data.Foldable as F -import Data.Function (fix) import qualified Data.HashMap.Strict as HashMap -import Data.List (intercalate) +import qualified Data.HashSet as HashSet +import Data.List (intercalate, maximum) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (maybeToList, catMaybes, isJust) -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Text.Encoding (decodeUtf8) import Data.Text.Metrics -import Data.Typeable (Typeable) -import Data.Word (Word64) import Network.HTTP.Download import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO -import Prelude -- Fix AMP warning import Stack.PackageIndex import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName +import Stack.Types.Runner import Stack.Types.Version -import System.FilePath ((<.>)) import qualified System.FilePath as FP -import System.IO +import System.IO (hSeek, SeekMode (AbsoluteSeek)) import System.PosixCompat (setFileMode) -type PackageCaches = Map PackageIdentifier (PackageIndex, PackageCache) - data FetchException = Couldn'tReadIndexTarball FilePath Tar.FormatError | Couldn'tReadPackageTarball FilePath SomeException | UnpackDirectoryAlreadyExists (Set FilePath) | CouldNotParsePackageSelectors [String] | UnknownPackageNames (Set PackageName) - | UnknownPackageIdentifiers (Set PackageIdentifier) String + | UnknownPackageIdentifiers (HashSet PackageIdentifierRevision) String + Bool -- Do we use any 00-index.tar.gz indices? Just used for more informative error messages deriving Typeable instance Exception FetchException @@ -114,15 +98,14 @@ show (UnknownPackageNames names) = "The following packages were not found in your indices: " ++ intercalate ", " (map packageNameString $ Set.toList names) - show (UnknownPackageIdentifiers idents suggestions) = + show (UnknownPackageIdentifiers idents suggestions uses00Index) = "The following package identifiers were not found in your indices: " ++ - intercalate ", " (map packageIdentifierString $ Set.toList idents) ++ - (if null suggestions then "" else "\n" ++ suggestions) + intercalate ", " (map packageIdentifierRevisionString $ HashSet.toList idents) ++ + (if null suggestions then "" else "\n" ++ suggestions) ++ + (if uses00Index then "\n\nYou seem to be using a legacy 00-index.tar.gz tarball.\nConsider changing your configuration to use a 01-index.tar.gz file.\nAlternatively, you can set the ignore-revision-mismatch setting to true.\nFor more information, see: https://github.com/commercialhaskell/stack/issues/3520" else "") -- | Fetch packages into the cache without unpacking -fetchPackages :: (StackMiniM env m, HasConfig env) - => Set PackageIdentifier - -> m () +fetchPackages :: HasConfig env => Set PackageIdentifier -> RIO env () fetchPackages idents' = do resolved <- resolvePackages Nothing idents Set.empty ToFetchResult toFetch alreadyUnpacked <- getToFetch Nothing resolved @@ -131,28 +114,26 @@ assert (Map.null nowUnpacked) (return ()) where -- Since we're just fetching tarballs and not unpacking cabal files, we can - -- always provide a Nothing Git SHA - idents = Map.fromList $ map (, Nothing) $ Set.toList idents' + -- always provide a CFILatest cabal file info + idents = map (flip PackageIdentifierRevision CFILatest) $ Set.toList idents' -- | Intended to work for the command line command. -unpackPackages :: (StackMiniM env m, HasConfig env) - => Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan +unpackPackages :: HasConfig env + => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan -> FilePath -- ^ destination -> [String] -- ^ names or identifiers - -> m () -unpackPackages mMiniBuildPlan dest input = do + -> RIO env () +unpackPackages mSnapshotDef dest input = do dest' <- resolveDir' dest (names, idents) <- case partitionEithers $ map parse input of ([], x) -> return $ partitionEithers x (errs, _) -> throwM $ CouldNotParsePackageSelectors errs - resolved <- resolvePackages mMiniBuildPlan - (Map.fromList idents) - (Set.fromList names) + resolved <- resolvePackages mSnapshotDef idents (Set.fromList names) ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved unless (Map.null alreadyUnpacked) $ throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked unpacked <- fetchPackages' Nothing toFetch - F.forM_ (Map.toList unpacked) $ \(ident, dest'') -> $logInfo $ T.pack $ concat + F.forM_ (Map.toList unpacked) $ \(ident, dest'') -> logInfo $ T.pack $ concat [ "Unpacked " , packageIdentifierString ident , " to " @@ -161,25 +142,40 @@ where -- Possible future enhancement: parse names as name + version range parse s = - case parsePackageNameFromString s of + case parsePackageName t of Right x -> Right $ Left x Left _ -> - case parsePackageIdentifierFromString s of - Right x -> Right $ Right (x, Nothing) - Left _ -> maybe (Left s) (Right . Right) $ do - (identS, '@':revisionS) <- return $ break (== '@') s - Right ident <- return $ parsePackageIdentifierFromString identS - hash <- T.stripPrefix "gitsha1:" $ T.pack revisionS - Just (ident, Just $ GitSHA1 $ encodeUtf8 hash) + case parsePackageIdentifierRevision t of + Right x -> Right $ Right x + Left _ -> Left s + where + t = T.pack s +-- | Same as 'unpackPackageIdents', but for a single package. +unpackPackageIdent + :: HasConfig env + => Path Abs Dir -- ^ unpack directory + -> Path Rel Dir -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 + -> PackageIdentifierRevision + -> RIO env (Path Abs Dir) +unpackPackageIdent unpackDir distDir (PackageIdentifierRevision ident mcfi) = do + -- FIXME make this more direct in the future + m <- unpackPackageIdents unpackDir (Just distDir) [PackageIdentifierRevision ident mcfi] + case Map.toList m of + [(ident', dir)] + | ident /= ident' -> error "unpackPackageIdent: ident mismatch" + | otherwise -> return dir + [] -> error "unpackPackageIdent: empty list" + _ -> error "unpackPackageIdent: multiple results" + -- | Ensure that all of the given package idents are unpacked into the build -- unpack directory, and return the paths to all of the subdirectories. unpackPackageIdents - :: (StackMiniM env m, HasConfig env) + :: HasConfig env => Path Abs Dir -- ^ unpack directory -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 - -> Map PackageIdentifier (Maybe GitSHA1) - -> m (Map PackageIdentifier (Path Abs Dir)) + -> [PackageIdentifierRevision] + -> RIO env (Map PackageIdentifier (Path Abs Dir)) unpackPackageIdents unpackDir mdistDir idents = do resolved <- resolvePackages Nothing idents Set.empty ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just unpackDir) resolved @@ -188,18 +184,19 @@ data ResolvedPackage = ResolvedPackage { rpIdent :: !PackageIdentifier - , rpCache :: !PackageCache + , rpDownload :: !(Maybe PackageDownload) + , rpOffsetSize :: !OffsetSize , rpIndex :: !PackageIndex } deriving Show -- | Resolve a set of package names and identifiers into @FetchPackage@ values. -resolvePackages :: (StackMiniM env m, HasConfig env) - => Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan - -> Map PackageIdentifier (Maybe GitSHA1) +resolvePackages :: HasConfig env + => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan + -> [PackageIdentifierRevision] -> Set PackageName - -> m [ResolvedPackage] -resolvePackages mMiniBuildPlan idents0 names0 = do + -> RIO env [ResolvedPackage] +resolvePackages mSnapshotDef idents0 names0 = do eres <- go case eres of Left _ -> do @@ -207,96 +204,106 @@ go >>= either throwM return Right x -> return x where - go = r <$> resolvePackagesAllowMissing mMiniBuildPlan idents0 names0 - r (missingNames, missingIdents, idents) + go = r <$> getUses00Index <*> resolvePackagesAllowMissing mSnapshotDef idents0 names0 + r uses00Index (missingNames, missingIdents, idents) | not $ Set.null missingNames = Left $ UnknownPackageNames missingNames - | not $ Set.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" + | not $ HashSet.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" uses00Index | otherwise = Right idents +-- | Does the configuration use a 00-index.tar.gz file for indices? +-- See +getUses00Index :: HasConfig env => RIO env Bool +getUses00Index = + any is00 <$> view packageIndicesL + where + is00 :: PackageIndex -> Bool + is00 index = "00-index.tar.gz" `T.isInfixOf` indexLocation index + +-- | Turn package identifiers and package names into a list of +-- @ResolvedPackage@s. Returns any unresolved names and +-- identifier. These are considered unresolved even if the only +-- mismatch is in the cabal file info (MSS 2017-07-17: old versions of +-- this code had special handling to treat missing cabal file info as +-- a warning, that's no longer necessary or desirable since all info +-- should be present and checked). resolvePackagesAllowMissing - :: (StackMiniM env m, HasConfig env) - => Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan - -> Map PackageIdentifier (Maybe GitSHA1) + :: forall env. HasConfig env + => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan + -> [PackageIdentifierRevision] -> Set PackageName - -> m (Set PackageName, Set PackageIdentifier, [ResolvedPackage]) -resolvePackagesAllowMissing mMiniBuildPlan idents0 names0 = do - (res1, res2, resolved) <- inner - if any (isJust . snd) resolved - then do - $logInfo "Missing some cabal revision files, updating indices" - updateAllIndices - (res1', res2', resolved') <- inner - - -- Print an error message if any SHAs are still missing. - F.forM_ resolved' $ \(rp, missing) -> F.forM_ missing $ \(GitSHA1 sha) -> - $logWarn $ mconcat - [ "Did not find .cabal file for " - , T.pack $ packageIdentifierString $ rpIdent rp - , " with SHA of " - , decodeUtf8 sha - , " in tarball-based cache" - ] + -> RIO env (Set PackageName, HashSet PackageIdentifierRevision, [ResolvedPackage]) +resolvePackagesAllowMissing mSnapshotDef idents0 names0 = do + cache@(PackageCache cache') <- getPackageCaches - return (res1', res2', map fst resolved') - else return (res1, res2, map fst resolved) - where - inner = do - (caches, shaCaches) <- getPackageCaches + -- Find out the latest versions of all packages in the cache + let versions = fmap (maximum . HashMap.keys) cache' - let versions = Map.fromListWith max $ map toTuple $ Map.keys caches + -- Determines the identifier for a given name, either from + -- snapshot information or by taking the latest version + -- available + getNamed :: PackageName -> Maybe PackageIdentifierRevision + getNamed = + case mSnapshotDef of + Nothing -> getNamedFromIndex + Just sd -> getNamedFromSnapshotDef sd - getNamed :: PackageName -> Maybe (PackageIdentifier, Maybe GitSHA1) - getNamed = - case mMiniBuildPlan of - Nothing -> getNamedFromIndex - Just mbp -> getNamedFromBuildPlan mbp + -- Use whatever is specified in the snapshot. TODO this does not + -- handle the case where a snapshot defines a package outside of + -- the index, we'd need a LoadedSnapshot for that. + getNamedFromSnapshotDef sd name = do + loop $ sdLocations sd + where + loop [] = Nothing + loop (PLIndex ident@(PackageIdentifierRevision (PackageIdentifier name' _) _):rest) + | name == name' = Just ident + | otherwise = loop rest + loop (_:rest) = loop rest - getNamedFromBuildPlan mbp name = do - mpi <- Map.lookup name $ mbpPackages mbp - Just (PackageIdentifier name (mpiVersion mpi), mpiGitSHA1 mpi) - getNamedFromIndex name = fmap - (\ver -> (PackageIdentifier name ver, Nothing)) - (Map.lookup name versions) + -- Take latest version available, including latest cabal file information + getNamedFromIndex name = fmap + (\ver -> PackageIdentifierRevision (PackageIdentifier name ver) CFILatest) + (HashMap.lookup name versions) - (missingNames, idents1) = partitionEithers $ map - (\name -> maybe (Left name) Right (getNamed name)) - (Set.toList names0) - let (missingIdents, resolved) = partitionEithers $ map (goIdent caches shaCaches) - $ Map.toList - $ idents0 <> Map.fromList idents1 - return (Set.fromList missingNames, Set.fromList missingIdents, resolved) + (missingNames, idents1) = partitionEithers $ map + (\name -> maybe (Left name) Right (getNamed name)) + (Set.toList names0) + config <- view configL + let (missingIdents, resolved) = + partitionEithers + $ map (\pir -> maybe (Left pir) Right (lookupResolvedPackage config pir cache)) + $ idents0 <> idents1 + return (Set.fromList missingNames, HashSet.fromList missingIdents, resolved) - goIdent caches shaCaches (ident, mgitsha) = - case Map.lookup ident caches of - Nothing -> Left ident - Just (index, cache) -> - let (index', cache', missingGitSHA) = - case mgitsha of - Nothing -> (index, cache, mgitsha) - Just gitsha -> - case HashMap.lookup gitsha shaCaches of - Just (index'', offsetSize) -> - ( index'' - , cache { pcOffsetSize = offsetSize } - -- we already got the info - -- about this SHA, don't do - -- any lookups later - , Nothing - ) - -- Index using HTTP, so we're missing the Git SHA - Nothing -> (index, cache, mgitsha) - in Right (ResolvedPackage - { rpIdent = ident - , rpCache = cache' - , rpIndex = index' - }, missingGitSHA) +lookupResolvedPackage :: Config -> PackageIdentifierRevision -> PackageCache PackageIndex -> Maybe ResolvedPackage +lookupResolvedPackage config (PackageIdentifierRevision ident@(PackageIdentifier name version) cfi) (PackageCache cache) = do + (index, mdownload, files) <- HashMap.lookup name cache >>= HashMap.lookup version + let moffsetSize = + case cfi of + CFILatest -> Just $ snd $ NE.last files + CFIHash _msize hash' -> -- TODO check size? + lookup hash' + $ concatMap (\(hashes, x) -> map (, x) hashes) + $ NE.toList files + CFIRevision rev -> fmap snd $ listToMaybe $ drop (fromIntegral rev) $ NE.toList files + offsetSize <- + case moffsetSize of + Just x -> Just x + Nothing + | configIgnoreRevisionMismatch config -> Just $ snd $ NE.last files + | otherwise -> Nothing + Just ResolvedPackage + { rpIdent = ident + , rpDownload = mdownload + , rpOffsetSize = offsetSize + , rpIndex = index + } data ToFetch = ToFetch { tfTarball :: !(Path Abs File) , tfDestDir :: !(Maybe (Path Abs Dir)) , tfUrl :: !T.Text , tfSize :: !(Maybe Word64) - , tfSHA256 :: !(Maybe ByteString) + , tfSHA256 :: !(Maybe StaticSHA256) , tfCabal :: !ByteString -- ^ Contents of the .cabal file } @@ -308,20 +315,18 @@ -- | Add the cabal files to a list of idents with their caches. withCabalFiles - :: (StackMiniM env m, HasConfig env) + :: (MonadReader env m, MonadUnliftIO m, HasConfig env, MonadThrow m) => IndexName -> [(ResolvedPackage, a)] -> (PackageIdentifier -> a -> ByteString -> IO b) -> m [b] withCabalFiles name pkgs f = do indexPath <- configPackageIndex name - bracket - (liftIO $ openBinaryFile (toFilePath indexPath) ReadMode) - (liftIO . hClose) $ \h -> mapM (goPkg h) pkgs + withBinaryFile (toFilePath indexPath) ReadMode + $ \h -> mapM (goPkg h) pkgs where - goPkg h (ResolvedPackage ident pc _index, tf) = do + goPkg h (ResolvedPackage { rpIdent = ident, rpOffsetSize = OffsetSize offset size }, tf) = do -- Did not find warning for tarballs is handled above - let OffsetSize offset size = pcOffsetSize pc liftIO $ do hSeek h AbsoluteSeek $ fromIntegral offset cabalBS <- S.hGet h $ fromIntegral size @@ -330,49 +335,47 @@ -- | Provide a function which will load up a cabal @ByteString@ from the -- package indices. withCabalLoader - :: (StackMiniM env m, HasConfig env, MonadBaseUnlift IO m) - => ((PackageIdentifier -> IO ByteString) -> m a) - -> m a + :: HasConfig env + => ((PackageIdentifierRevision -> IO ByteString) -> RIO env a) + -> RIO env a withCabalLoader inner = do - env <- ask - -- Want to try updating the index once during a single run for missing -- package identifiers. We also want to ensure we only update once at a -- time -- -- TODO: probably makes sense to move this concern into getPackageCaches - updateRef <- liftIO $ newMVar True + updateRef <- newMVar True - loadCaches <- getPackageCachesIO - runInBase <- liftBaseWith $ \run -> return (void . run) - unlift <- askRunBase + u <- askUnliftIO -- TODO in the future, keep all of the necessary @Handle@s open - let doLookup :: PackageIdentifier + let doLookup :: PackageIdentifierRevision -> IO ByteString doLookup ident = do - (caches, _gitSHACaches) <- loadCaches - eres <- unlift $ lookupPackageIdentifierExact ident env caches + bothCaches <- unliftIO u getPackageCaches + eres <- unliftIO u $ lookupPackageIdentifierExact ident bothCaches case eres of Just bs -> return bs -- Update the cache and try again Nothing -> do - let fuzzy = fuzzyLookupCandidates ident caches + let fuzzy = fuzzyLookupCandidates ident bothCaches suggestions = case fuzzy of - Nothing -> - case typoCorrectionCandidates ident caches of - Nothing -> "" - Just cs -> "Perhaps you meant " <> - orSeparated cs <> "?" - Just cs -> "Possible candidates: " <> + FRNameNotFound Nothing -> "" + FRNameNotFound (Just cs) -> + "Perhaps you meant " <> orSeparated cs <> "?" + FRVersionNotFound cs -> "Possible candidates: " <> commaSeparated (NE.map packageIdentifierText cs) <> "." + FRRevisionNotFound cs -> + "The specified revision was not found.\nPossible candidates: " <> + commaSeparated (NE.map (T.pack . packageIdentifierRevisionString) cs) + <> "." join $ modifyMVar updateRef $ \toUpdate -> if toUpdate then do - runInBase $ do - $logInfo $ T.concat + unliftIO u $ do + logInfo $ T.concat [ "Didn't see " - , T.pack $ packageIdentifierString ident + , T.pack $ packageIdentifierRevisionString ident , " in your package indices.\n" , "Updating and trying again." ] @@ -380,68 +383,78 @@ _ <- getPackageCaches return () return (False, doLookup ident) - else return (toUpdate, - throwM $ UnknownPackageIdentifiers - (Set.singleton ident) (T.unpack suggestions)) + else do + uses00Index <- unliftIO u getUses00Index + return (toUpdate, throwIO $ UnknownPackageIdentifiers + (HashSet.singleton ident) (T.unpack suggestions) uses00Index) inner doLookup lookupPackageIdentifierExact - :: (StackMiniM env m, HasConfig env) - => PackageIdentifier - -> env - -> PackageCaches + :: (MonadReader env m, MonadUnliftIO m, HasConfig env, MonadThrow m) + => PackageIdentifierRevision + -> PackageCache PackageIndex -> m (Maybe ByteString) -lookupPackageIdentifierExact ident env caches = - case Map.lookup ident caches of - Nothing -> return Nothing - Just (index, cache) -> do - [bs] <- flip runReaderT env - $ withCabalFiles (indexName index) - [(ResolvedPackage - { rpIdent = ident - , rpCache = cache - , rpIndex = index - }, ())] - $ \_ _ bs -> return bs - return $ Just bs +lookupPackageIdentifierExact identRev cache = do + config <- view configL + forM (lookupResolvedPackage config identRev cache) $ \rp -> do + [bs] <- withCabalFiles (indexName (rpIndex rp)) [(rp, ())] $ \_ _ bs -> return bs + return bs +data FuzzyResults + = FRNameNotFound !(Maybe (NonEmpty T.Text)) + | FRVersionNotFound !(NonEmpty PackageIdentifier) + | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision) + -- | Given package identifier and package caches, return list of packages -- with the same name and the same two first version number components found -- in the caches. fuzzyLookupCandidates - :: PackageIdentifier - -> PackageCaches - -> Maybe (NonEmpty PackageIdentifier) -fuzzyLookupCandidates (PackageIdentifier name ver) 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) + :: PackageIdentifierRevision + -> PackageCache index + -> FuzzyResults +fuzzyLookupCandidates (PackageIdentifierRevision (PackageIdentifier name ver) _rev) (PackageCache caches) = + case HashMap.lookup name caches of + Nothing -> FRNameNotFound $ typoCorrectionCandidates name (PackageCache caches) + Just m -> + case HashMap.lookup ver m of + Nothing -> + case NE.nonEmpty $ filter sameMajor $ HashMap.keys m of + Just vers -> FRVersionNotFound $ NE.map (PackageIdentifier name) vers + Nothing -> + case NE.nonEmpty $ HashMap.keys m of + Nothing -> error "fuzzyLookupCandidates: no versions" + Just vers -> FRVersionNotFound $ NE.map (PackageIdentifier name) vers + Just (_index, _mpd, revisions) -> + let hashes = concatMap fst $ NE.toList revisions + pirs = map (PackageIdentifierRevision (PackageIdentifier name ver) . CFIHash Nothing) hashes + in case NE.nonEmpty pirs of + Nothing -> error "fuzzyLookupCandidates: no revisions" + Just pirs' -> FRRevisionNotFound pirs' + where + sameMajor v = toMajorVersion v == toMajorVersion ver -- | Try to come up with typo corrections for given package identifier using -- package caches. This should be called before giving up, i.e. when -- 'fuzzyLookupCandidates' cannot return anything. typoCorrectionCandidates - :: PackageIdentifier - -> PackageCaches + :: PackageName + -> PackageCache index -> Maybe (NonEmpty T.Text) -typoCorrectionCandidates ident = - let getName = packageNameText . packageIdentifierName - name = getName ident +typoCorrectionCandidates name' (PackageCache cache) = + let name = packageNameText name' in NE.nonEmpty . take 10 . map snd . filter (\(distance, _) -> distance < 4) - . map (\(k, _) -> (damerauLevenshtein name (getName k), getName k)) - . Map.toList + . map (\k -> (damerauLevenshtein name (packageNameText k), packageNameText k)) + . HashMap.keys + $ cache -- | Figure out where to fetch from. -getToFetch :: (StackMiniM env m, HasConfig env) +getToFetch :: HasConfig env => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack -> [ResolvedPackage] - -> m ToFetchResult + -> RIO env ToFetchResult getToFetch mdest resolvedAll = do (toFetch0, unpacked) <- liftM partitionEithers $ mapM checkUnpacked resolvedAll toFetch1 <- mapM goIndex $ Map.toList $ Map.fromListWith (++) toFetch0 @@ -464,7 +477,7 @@ Just destDir -> return $ Right (ident, destDir) Nothing -> do let index = rpIndex resolved - d = pcDownload $ rpCache resolved + d = rpDownload resolved targz = T.pack $ packageIdentifierString ident ++ ".tar.gz" tarball <- configPackageTarball (indexName index) ident return $ Left (indexName index, [(resolved, ToFetch @@ -497,40 +510,40 @@ -- @ -- -- Since 0.1.0.0 -fetchPackages' :: (StackMiniM env m, HasConfig env) +fetchPackages' :: HasConfig env => Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 -> Map PackageIdentifier ToFetch - -> m (Map PackageIdentifier (Path Abs Dir)) + -> RIO env (Map PackageIdentifier (Path Abs Dir)) fetchPackages' mdistDir toFetchAll = do connCount <- view $ configL.to configConnectionCount outputVar <- liftIO $ newTVarIO Map.empty - runInBase <- liftBaseWith $ \run -> return (void . run) + run <- askRunInIO parMapM_ connCount - (go outputVar runInBase) + (go outputVar run) (Map.toList toFetchAll) liftIO $ readTVarIO outputVar where - go :: (MonadIO m,MonadThrow m,MonadLogger m) + go :: (MonadUnliftIO m,MonadThrow m,MonadLogger m,HasRunner env, MonadReader env m) => TVar (Map PackageIdentifier (Path Abs Dir)) -> (m () -> IO ()) -> (PackageIdentifier, ToFetch) -> m () - go outputVar runInBase (ident, toFetch) = do + go outputVar run (ident, toFetch) = do req <- parseUrlThrow $ T.unpack $ tfUrl toFetch let destpath = tfTarball toFetch let toHashCheck bs = HashCheck SHA256 (CheckHexDigestByteString bs) let downloadReq = DownloadRequest { drRequest = req - , drHashChecks = map toHashCheck $ maybeToList (tfSHA256 toFetch) + , drHashChecks = map (toHashCheck . staticSHA256ToBase16) $ maybeToList (tfSHA256 toFetch) , drLengthCheck = fromIntegral <$> tfSize toFetch , drRetryPolicy = drRetryPolicyDefault } let progressSink _ = - liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download" + liftIO $ run $ logInfo $ packageIdentifierText ident <> ": download" _ <- verifiedDownload downloadReq destpath progressSink identStrP <- parseRelDir $ packageIdentifierString ident @@ -561,13 +574,13 @@ let cabalFP = innerDest FP. packageNameString (packageIdentifierName ident) - <.> "cabal" + FP.<.> "cabal" S.writeFile cabalFP $ tfCabal toFetch atomically $ modifyTVar outputVar $ Map.insert ident destDir F.forM_ unexpectedEntries $ \(path, entryType) -> - $logWarn $ "Unexpected entry type " <> entryType <> " for entry " <> T.pack path + logWarn $ "Unexpected entry type " <> entryType <> " for entry " <> T.pack path -- | Internal function used to unpack tarball. -- @@ -631,30 +644,24 @@ perm) filePerms return unexpectedEntries -parMapM_ :: (F.Foldable f,MonadIO m,MonadBaseControl IO m) +parMapM_ :: (F.Foldable f,MonadUnliftIO m) => Int -> (a -> m ()) -> f a -> m () parMapM_ (max 1 -> 1) f xs = F.mapM_ f xs -parMapM_ cnt f xs0 = do - var <- liftIO (newTVarIO $ F.toList xs0) - - -- See comment on similar line in Stack.Build - runInBase <- liftBaseWith $ \run -> return (void . run) +parMapM_ cnt f xs0 = withRunInIO $ \run -> do + var <- newTVarIO $ F.toList xs0 - let worker = fix $ \loop -> join $ atomically $ do - xs <- readTVar var - case xs of - [] -> return $ return () - x:xs' -> do - writeTVar var xs' - return $ do - runInBase $ f x - loop - workers 1 = Concurrently worker - workers i = Concurrently worker *> workers (i - 1) - liftIO $ runConcurrently $ workers cnt + replicateConcurrently_ cnt $ fix $ \loop -> join $ atomically $ do + xs <- readTVar var + case xs of + [] -> return $ return () + x:xs' -> do + writeTVar var xs' + return $ do + run $ f x + loop orSeparated :: NonEmpty T.Text -> T.Text orSeparated xs diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs --- a/src/Stack/FileWatch.hs +++ b/src/Stack/FileWatch.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module Stack.FileWatch @@ -8,24 +9,17 @@ import Blaze.ByteString.Builder (toLazyByteString, copyByteString) import Blaze.ByteString.Builder.Char.Utf8 (fromShow) -import Control.Concurrent.Async (race_) import Control.Concurrent.STM -import Control.Exception (Exception, fromException, catch, throwIO) -import Control.Exception.Safe (tryAny) -import Control.Monad (forever, unless, when) +import Stack.Prelude import qualified Data.ByteString.Lazy as L import qualified Data.Map.Strict as Map -import Data.Monoid ((<>)) -import Data.Set (Set) import qualified Data.Set as Set -import Data.String (fromString) -import Data.Traversable (forM) import GHC.IO.Exception import GHC.IO.Handle (hIsTerminalDevice) import Path import System.Console.ANSI import System.FSNotify -import System.IO (Handle, stdout, stderr, hPutStrLn) +import System.IO (stdout, stderr, hPutStrLn, getLine) -- | Print an exception to stderr printExceptionStderr :: Exception e => e -> IO () diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -1,4 +1,5 @@ --- FIXME See how much of this module can be deleted. +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} @@ -11,33 +12,23 @@ module Stack.GhcPkg (getGlobalDB - ,EnvOverride - ,envHelper ,findGhcPkgField ,createDatabase ,unregisterGhcPkgId ,getCabalPkgVer ,ghcPkgExeName + ,ghcPkgPathEnvVar ,mkGhcPackagePath) where -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Trans.Control +import Stack.Prelude import qualified Data.ByteString.Char8 as S8 -import Data.Either import Data.List -import Data.Maybe -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Data.Text.Extra (stripCR) -import Path (Path, Abs, Dir, toFilePath, parent, mkRelFile, ()) +import Path (parent, mkRelFile, ()) import Path.Extra (toFilePathNoTrailingSep) import Path.IO -import Prelude hiding (FilePath) import Stack.Constants import Stack.Types.Build import Stack.Types.GhcPkgId @@ -49,15 +40,15 @@ import System.Process.Read -- | Get the global package database -getGlobalDB :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +getGlobalDB :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> m (Path Abs Dir) getGlobalDB menv wc = do - $logDebug "Getting global package database location" + logDebug "Getting global package database location" -- This seems like a strange way to get the global package database -- location, but I don't know of a better one - bs <- ghcPkg menv wc [] ["list", "--global"] >>= either throwM return + bs <- ghcPkg menv wc [] ["list", "--global"] >>= either throwIO return let fp = S8.unpack $ stripTrailingColon $ firstLine bs - resolveDir' fp + liftIO $ resolveDir' fp where stripTrailingColon bs | S8.null bs = bs @@ -66,7 +57,7 @@ firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n') -- | Run the ghc-pkg executable -ghcPkg :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +ghcPkg :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] @@ -84,7 +75,7 @@ args' = packageDbFlags pkgDbs ++ args -- | Create a package database in the given directory, if it doesn't exist. -createDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +createDatabase :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> Path Abs Dir -> m () createDatabase menv wc db = do exists <- doesFileExist (db $(mkRelFile "package.cache")) @@ -95,12 +86,12 @@ dirExists <- doesDirExist db args <- if dirExists then do - $logWarn $ T.pack $ concat + logWarn $ T.pack $ concat [ "The package database located at " , toFilePath db , " is corrupted (missing its package.cache file)." ] - $logWarn "Proceeding with a recache" + logWarn "Proceeding with a recache" return ["--package-db", toFilePath db, "recache"] else do -- Creating the parent doesn't seem necessary, as ghc-pkg @@ -111,8 +102,8 @@ eres <- tryProcessStdout Nothing menv (ghcPkgExeName wc) args case eres of Left e -> do - $logError $ T.pack $ "Unable to create package database at " ++ toFilePath db - throwM e + logError $ T.pack $ "Unable to create package database at " ++ toFilePath db + throwIO e Right _ -> return () -- | Get the name to use for "ghc-pkg", given the compiler version. @@ -120,6 +111,11 @@ ghcPkgExeName Ghc = "ghc-pkg" ghcPkgExeName Ghcjs = "ghcjs-pkg" +-- | Get the environment variable to use for the package DB paths. +ghcPkgPathEnvVar :: WhichCompiler -> Text +ghcPkgPathEnvVar Ghc = "GHC_PACKAGE_PATH" +ghcPkgPathEnvVar Ghcjs = "GHCJS_PACKAGE_PATH" + -- | Get the necessary ghc-pkg flags for setting up the given package database packageDbFlags :: [Path Abs Dir] -> [String] packageDbFlags pkgDbs = @@ -128,7 +124,7 @@ -- | Get the value of a field of the package. findGhcPkgField - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ package databases @@ -149,7 +145,7 @@ fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines lbs -- | Get the version of the package -findGhcPkgVersion :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +findGhcPkgVersion :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ package databases @@ -161,10 +157,10 @@ Just !v -> return (parseVersion v) _ -> return Nothing -unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) +unregisterGhcPkgId :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler - -> CompilerVersion + -> CompilerVersion 'CVActual -> Path Abs Dir -- ^ package database -> GhcPkgId -> PackageIdentifier @@ -172,7 +168,7 @@ unregisterGhcPkgId menv wc cv pkgDb gid ident = do eres <- ghcPkg menv wc [pkgDb] args case eres of - Left e -> $logWarn $ T.pack $ show e + Left e -> logWarn $ T.pack $ show e Right _ -> return () where -- TODO ideally we'd tell ghc-pkg a GhcPkgId instead @@ -183,16 +179,16 @@ _ -> ["--ipid", ghcPkgIdString gid]) -- | Get the version of Cabal from the global package database. -getCabalPkgVer :: (MonadThrow m, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +getCabalPkgVer :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> m Version getCabalPkgVer menv wc = do - $logDebug "Getting Cabal package version" + logDebug "Getting Cabal package version" mres <- findGhcPkgVersion menv wc [] -- global DB cabalPackageName - maybe (throwM $ Couldn'tFindPkgId cabalPackageName) return mres + maybe (throwIO $ Couldn'tFindPkgId cabalPackageName) return mres -- | Get the value for GHC_PACKAGE_PATH mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -14,50 +15,27 @@ , GhciPkgInfo(..) , GhciException(..) , ghci - - -- TODO: Address what should and should not be exported. - , renderScriptGhci - , renderScriptIntero ) where -import Control.Applicative -import Control.Arrow (second) -import Control.Exception.Safe (tryAny) -import Control.Monad hiding (forM) -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Logger +import Stack.Prelude import Control.Monad.State.Strict (State, execState, get, modify) -import Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.ByteString.Char8 as S8 -import Data.Either -import Data.Function import Data.List import Data.List.Extra (nubOrd) -import Data.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.String -import Data.Text (Text) import qualified Data.Text as T -import Data.Traversable (forM) -import Data.Typeable (Typeable) import qualified Distribution.PackageDescription as C import qualified Distribution.Text as C import Path import Path.Extra (toFilePathNoTrailingSep) -import Path.IO -import Prelude +import Path.IO hiding (withSystemTempDir) import Stack.Build import Stack.Build.Installed import Stack.Build.Source import Stack.Build.Target import Stack.Config (getLocalPackages) -import Stack.Constants +import Stack.Constants.Config import Stack.Exec import Stack.Ghci.Script import Stack.Package @@ -69,8 +47,8 @@ import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT -import Text.Read (readMaybe) +import Stack.Types.Runner +import System.IO (putStrLn, putStr, getLine) #ifndef WINDOWS import qualified System.Posix.Files as Posix @@ -88,8 +66,9 @@ , ghciMainIs :: !(Maybe Text) , ghciLoadLocalDeps :: !Bool , ghciSkipIntermediate :: !Bool - , ghciHidePackages :: !Bool + , ghciHidePackages :: !(Maybe Bool) , ghciNoBuild :: !Bool + , ghciOnlyMain :: !Bool } deriving Show -- | Necessary information to load a package or its components. @@ -111,6 +90,7 @@ | MissingFileTarget String | Can'tSpecifyFilesAndTargets | Can'tSpecifyFilesAndMainIs + | GhciTargetParseException [Text] deriving (Typeable) instance Exception GhciException @@ -125,14 +105,17 @@ show (MissingFileTarget name) = "Cannot find file target " ++ name show Can'tSpecifyFilesAndTargets = - "Cannot use 'stack ghci' with both file targets and build targets" + "Cannot use 'stack ghci' with both file targets and package targets" show Can'tSpecifyFilesAndMainIs = "Cannot use 'stack ghci' with both file targets and --main-is flag" + show (GhciTargetParseException xs) = + show (TargetParseException xs) ++ + "\nNote that to specify options to be passed to GHCi, use the --ghci-options flag" -- | Launch a GHCi session for the given local package targets with the -- given options and configure it with the load paths and extensions -- of those targets. -ghci :: (StackM r m, HasEnvConfig r, MonadBaseUnlift IO m) => GhciOpts -> m () +ghci :: HasEnvConfig env => GhciOpts -> RIO env () ghci opts@GhciOpts{..} = do let buildOptsCLI = defaultBuildOptsCLI { boptsCLITargets = [] @@ -143,8 +126,9 @@ -- Parse --main-is argument. mainIsTargets <- parseMainIsTargets buildOptsCLI ghciMainIs -- Parse to either file targets or build targets - etargets <- preprocessTargets ghciTargets + etargets <- preprocessTargets buildOptsCLI ghciTargets (inputTargets, mfileTargets) <- case etargets of + Right packageTargets -> return (packageTargets, Nothing) Left rawFileTargets -> do case mainIsTargets of Nothing -> return () @@ -152,51 +136,58 @@ -- Figure out targets based on filepath targets (targetMap, fileInfo, extraFiles) <- findFileTargets locals rawFileTargets return (targetMap, Just (fileInfo, extraFiles)) - Right rawTargets -> do - (_,_,normalTargets) <- parseTargetsFromBuildOpts AllowNoTargets buildOptsCLI - { boptsCLITargets = rawTargets } - return (normalTargets, Nothing) - -- Make sure the targets are known. - checkTargets inputTargets -- Get a list of all the local target packages. localTargets <- getAllLocalTargets opts inputTargets mainIsTargets sourceMap + -- Get a list of all the non-local target packages. + nonLocalTargets <- getAllNonLocalTargets inputTargets -- Check if additional package arguments are sensible. addPkgs <- checkAdditionalPackages ghciAdditionalPackages -- Build required dependencies and setup local packages. + stackYaml <- view stackYamlL buildDepsAndInitialSteps opts (map (packageNameText . fst) localTargets) + targetWarnings stackYaml localTargets nonLocalTargets mfileTargets -- Load the list of modules _after_ building, to catch changes in unlisted dependencies (#1180) pkgs <- getGhciPkgInfos buildOptsCLI sourceMap addPkgs (fmap fst mfileTargets) localTargets checkForIssues pkgs -- Finally, do the invocation of ghci - runGhci opts localTargets mainIsTargets pkgs (maybe [] snd mfileTargets) + runGhci opts localTargets mainIsTargets pkgs (maybe [] snd mfileTargets) (nonLocalTargets ++ addPkgs) -preprocessTargets :: (StackM r m) => [Text] -> m (Either [Path Abs File] [Text]) -preprocessTargets rawTargets = do - let (fileTargetsRaw, normalTargets) = +preprocessTargets :: HasEnvConfig env => BuildOptsCLI -> [Text] -> RIO env (Either [Path Abs File] (Map PackageName Target)) +preprocessTargets buildOptsCLI rawTargets = do + let (fileTargetsRaw, normalTargetsRaw) = partition (\t -> ".hs" `T.isSuffixOf` t || ".lhs" `T.isSuffixOf` t) rawTargets - fileTargets <- forM fileTargetsRaw $ \fp0 -> do - let fp = T.unpack fp0 - mpath <- forgivingAbsence (resolveFile' fp) - case mpath of - Nothing -> throwM (MissingFileTarget fp) - Just path -> return path - case (null fileTargets, null normalTargets) of - (False, False) -> throwM Can'tSpecifyFilesAndTargets - (False, _) -> return (Left fileTargets) - _ -> return (Right normalTargets) + -- Only use file targets if we have no normal targets. + if not (null fileTargetsRaw) && null normalTargetsRaw + then do + fileTargets <- forM fileTargetsRaw $ \fp0 -> do + let fp = T.unpack fp0 + mpath <- liftIO $ forgivingAbsence (resolveFile' fp) + case mpath of + Nothing -> throwM (MissingFileTarget fp) + Just path -> return path + return (Left fileTargets) + else do + -- Try parsing targets before checking if both file and + -- module targets are specified (see issue#3342). + (_,_,normalTargets) <- parseTargets AllowNoTargets buildOptsCLI { boptsCLITargets = normalTargetsRaw } + `catch` \ex -> case ex of + TargetParseException xs -> throwM (GhciTargetParseException xs) + _ -> throwM ex + unless (null fileTargetsRaw) $ throwM Can'tSpecifyFilesAndTargets + return (Right normalTargets) -parseMainIsTargets :: (StackM r m, HasEnvConfig r) => BuildOptsCLI -> Maybe Text -> m (Maybe (Map PackageName SimpleTarget)) +parseMainIsTargets :: HasEnvConfig env => BuildOptsCLI -> Maybe Text -> RIO env (Maybe (Map PackageName Target)) parseMainIsTargets buildOptsCLI mtarget = forM mtarget $ \target -> do - (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets buildOptsCLI + (_,_,targets) <- parseTargets AllowNoTargets buildOptsCLI { boptsCLITargets = [target] } return targets findFileTargets - :: (StackM r m, HasEnvConfig r) + :: HasEnvConfig env => [LocalPackage] -> [Path Abs File] - -> m (Map PackageName SimpleTarget, Map PackageName (Set (Path Abs File)), [Path Abs File]) + -> RIO env (Map PackageName Target, Map PackageName (Set (Path Abs File)), [Path Abs File]) findFileTargets locals fileTargets = do filePackages <- forM locals $ \lp -> do (_,compFiles,_,_) <- getPackageFiles (packageFiles (lpPackage lp)) (lpCabalFile lp) @@ -211,18 +202,20 @@ results <- forM foundFileTargetComponents $ \(fp, xs) -> case xs of [] -> do - $prettyWarn $ - "Couldn't find a component for file target" <+> - display fp <> - ". Attempting to load anyway." + prettyWarn $ vsep + [ "Couldn't find a component for file target" <+> + display fp <> + ". This means that the correct ghc options might not be used." + , "Attempting to load the file anyway." + ] return $ Left fp [x] -> do - $prettyInfo $ + prettyInfo $ "Using configuration for" <+> display x <+> "to load" <+> display fp return $ Right (fp, x) (x:_) -> do - $prettyWarn $ + prettyWarn $ "Multiple components contain file target" <+> display fp <> ":" <+> mconcat (intersperse ", " (map display xs)) <> line <> @@ -230,8 +223,8 @@ return $ Right (fp, x) let (extraFiles, associatedFiles) = partitionEithers results targetMap = - foldl unionSimpleTargets M.empty $ - map (\(_, (name, comp)) -> M.singleton name (STLocalComps (S.singleton comp))) + foldl unionTargets M.empty $ + map (\(_, (name, comp)) -> M.singleton name (TargetComps (S.singleton comp))) associatedFiles infoMap = foldl (M.unionWith S.union) M.empty $ @@ -239,43 +232,28 @@ associatedFiles return (targetMap, infoMap, extraFiles) -checkTargets - :: (StackM r m, HasEnvConfig r) - => Map PackageName SimpleTarget - -> m () -checkTargets mp = do - let filtered = M.filter (== STUnknown) mp - unless (M.null filtered) $ do - bconfig <- view buildConfigL - throwM $ UnknownTargets (M.keysSet filtered) M.empty (bcStackYaml bconfig) - getAllLocalTargets - :: (StackM r m, HasEnvConfig r) + :: HasEnvConfig env => GhciOpts - -> Map PackageName SimpleTarget - -> Maybe (Map PackageName SimpleTarget) + -> Map PackageName Target + -> Maybe (Map PackageName Target) -> SourceMap - -> m [(PackageName, (Path Abs File, SimpleTarget))] + -> RIO env [(PackageName, (Path Abs File, Target))] getAllLocalTargets GhciOpts{..} targets0 mainIsTargets sourceMap = do -- Use the 'mainIsTargets' as normal targets, for CLI concision. See -- #1845. This is a little subtle - we need to do the target parsing -- independently in order to handle the case where no targets are -- specified. - let targets = maybe targets0 (unionSimpleTargets targets0) mainIsTargets - packages <- getLocalPackages + let targets = maybe targets0 (unionTargets targets0) mainIsTargets + packages <- lpProject <$> getLocalPackages -- Find all of the packages that are directly demanded by the -- targets. directlyWanted <- forMaybeM (M.toList packages) $ - \(dir,treatLikeExtraDep) -> - do cabalfp <- findOrGenerateCabalFile dir - name <- parsePackageNameFromFilePath cabalfp - if treatLikeExtraDep - then return Nothing - else case M.lookup name targets of - Just simpleTargets -> - return (Just (name, (cabalfp, simpleTargets))) - Nothing -> return Nothing + \(name, lpv) -> + case M.lookup name targets of + Just simpleTargets -> return (Just (name, (lpvCabalFP lpv, simpleTargets))) + Nothing -> return Nothing -- Figure out let extraLoadDeps = getExtraLoadDeps ghciLoadLocalDeps sourceMap directlyWanted if (ghciSkipIntermediate && not ghciLoadLocalDeps) || null extraLoadDeps @@ -283,12 +261,12 @@ else do let extraList = T.intercalate ", " (map (packageNameText . fst) extraLoadDeps) if ghciLoadLocalDeps - then $logInfo $ T.concat + then logInfo $ T.concat [ "The following libraries will also be loaded into GHCi because " , "they are local dependencies of your targets, and you specified --load-local-deps:\n " , extraList ] - else $logInfo $ T.concat + else logInfo $ T.concat [ "The following libraries will also be loaded into GHCi because " , "they are intermediate dependencies of your targets:\n " , extraList @@ -296,7 +274,15 @@ ] return (directlyWanted ++ extraLoadDeps) -buildDepsAndInitialSteps :: (StackM r m, HasEnvConfig r, MonadBaseUnlift IO m) => GhciOpts -> [Text] -> m () +getAllNonLocalTargets + :: Map PackageName Target + -> RIO env [PackageName] +getAllNonLocalTargets targets = do + let isNonLocal (TargetAll Dependency) = True + isNonLocal _ = False + return $ map fst $ filter (isNonLocal . snd) (M.toList targets) + +buildDepsAndInitialSteps :: HasEnvConfig env => GhciOpts -> [Text] -> RIO env () buildDepsAndInitialSteps GhciOpts{..} targets0 = do let targets = targets0 ++ map T.pack ghciAdditionalPackages -- If necessary, do the build, for local packagee targets, only do @@ -311,8 +297,8 @@ case eres of Right () -> return () Left err -> do - $prettyError $ fromString (show err) - $prettyWarn "Build failed, but optimistically launching GHCi anyway" + prettyError $ fromString (show err) + prettyWarn "Build failed, but trying to launch GHCi anyway" checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName] checkAdditionalPackages pkgs = forM pkgs $ \name -> do @@ -321,39 +307,51 @@ maybe (throwM $ InvalidPackageOption name) return mres runGhci - :: (StackM r m, HasEnvConfig r) + :: HasEnvConfig env => GhciOpts - -> [(PackageName, (Path Abs File, SimpleTarget))] - -> Maybe (Map PackageName SimpleTarget) + -> [(PackageName, (Path Abs File, Target))] + -> Maybe (Map PackageName Target) -> [GhciPkgInfo] -> [Path Abs File] - -> m () -runGhci GhciOpts{..} targets mainIsTargets pkgs extraFiles = do + -> [PackageName] + -> RIO env () +runGhci GhciOpts{..} targets mainIsTargets pkgs extraFiles exposePackages = do config <- view configL wc <- view $ actualCompilerVersionL.whichCompilerL - let pkgopts = hidePkgOpt ++ genOpts ++ ghcOpts - hidePkgOpt = if null pkgs || not ghciHidePackages then [] else ["-hide-all-packages"] + let pkgopts = hidePkgOpts ++ genOpts ++ ghcOpts + shouldHidePackages = + fromMaybe (not (null pkgs && null exposePackages)) ghciHidePackages + hidePkgOpts = + if shouldHidePackages + then "-hide-all-packages" : + -- This is necessary, because current versions of ghci + -- will entirely fail to start if base isn't visible. This + -- is because it tries to use the interpreter to set + -- buffering options on standard IO. + "-package" : "base" : + concatMap (\n -> ["-package", packageNameString n]) exposePackages + else [] oneWordOpts bio - | ghciHidePackages = bioOneWordOpts bio ++ bioPackageFlags bio + | shouldHidePackages = bioOneWordOpts bio ++ bioPackageFlags bio | otherwise = bioOneWordOpts bio genOpts = nubOrd (concatMap (concatMap (oneWordOpts . snd) . ghciPkgOpts) pkgs) (omittedOpts, ghcOpts) = partition badForGhci $ - concatMap (concatMap (bioOpts . snd) . ghciPkgOpts) pkgs ++ - getUserOptions Nothing ++ - concatMap (getUserOptions . Just . ghciPkgName) pkgs - getUserOptions mpkg = - map T.unpack (M.findWithDefault [] mpkg (unGhcOptions (configGhcOptions config))) + concatMap (concatMap (bioOpts . snd) . ghciPkgOpts) pkgs ++ map T.unpack + ( fold (configGhcOptionsByCat config) -- include everything, locals, and targets + ++ concatMap (getUserOptions . ghciPkgName) pkgs + ) + getUserOptions pkg = M.findWithDefault [] pkg (configGhcOptionsByName config) badForGhci x = isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky -static -Werror") unless (null omittedOpts) $ - $logWarn + logWarn ("The following GHC options are incompatible with GHCi and have not been passed to it: " <> T.unwords (map T.pack (nubOrd omittedOpts))) oiDir <- view objectInterfaceDirL let odir = [ "-odir=" <> toFilePathNoTrailingSep oiDir , "-hidir=" <> toFilePathNoTrailingSep oiDir ] - $logInfo + logInfo ("Configuring GHCi with the following packages: " <> T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs)) let execGhci extras = do @@ -365,73 +363,66 @@ -- not include CWD. If there aren't any packages, CWD -- is included. (if null pkgs then id else ("-i" : )) $ - odir <> pkgopts <> map T.unpack ghciGhcOptions <> ghciArgs <> extras) - interrogateExeForRenderFunction = do - menv <- liftIO $ configEnvOverride config defaultEnvSettings - output <- execObserve menv (fromMaybe (compilerExeName wc) ghciGhcCommand) ["--version"] - if "Intero" `isPrefixOf` output - then return renderScriptIntero - else return renderScriptGhci + odir <> pkgopts <> extras <> map T.unpack ghciGhcOptions <> ghciArgs) + -- TODO: Consider optimizing this check. Perhaps if no + -- "with-ghc" is specified, assume that it is not using intero. + checkIsIntero = + -- Optimization dependent on the behavior of renderScript - + -- it doesn't matter if it's intero or ghci when loading + -- multiple packages. + case pkgs of + [_] -> do + menv <- liftIO $ configEnvOverride config defaultEnvSettings + output <- execObserve menv (fromMaybe (compilerExeName wc) ghciGhcCommand) ["--version"] + return $ "Intero" `isPrefixOf` output + _ -> return False withSystemTempDir "ghci" $ \tmpDirectory -> do macrosOptions <- writeMacrosFile tmpDirectory pkgs if ghciNoLoadModules then execGhci macrosOptions else do checkForDuplicateModules pkgs - renderFn <- interrogateExeForRenderFunction + isIntero <- checkIsIntero bopts <- view buildOptsL mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs - scriptPath <- writeGhciScript tmpDirectory (renderFn pkgs mainFile extraFiles) + scriptPath <- writeGhciScript tmpDirectory (renderScript isIntero pkgs mainFile ghciOnlyMain extraFiles) execGhci (macrosOptions ++ ["-ghci-script=" <> toFilePath scriptPath]) writeMacrosFile :: (MonadIO m) => Path Abs Dir -> [GhciPkgInfo] -> m [String] writeMacrosFile tmpDirectory packages = do - preprocessCabalMacros packages macrosFile + preprocessCabalMacros packages macrosFile where macrosFile = tmpDirectory $(mkRelFile "cabal_macros.h") writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m (Path Abs File) writeGhciScript tmpDirectory script = do - liftIO $ scriptToFile scriptPath script - setScriptPerms scriptFilePath - return scriptPath + liftIO $ scriptToFile scriptPath script + setScriptPerms scriptFilePath + return scriptPath where scriptPath = tmpDirectory $(mkRelFile "ghci-script") scriptFilePath = toFilePath scriptPath -findOwningPackageForMain :: [GhciPkgInfo] -> Path Abs File -> Maybe GhciPkgInfo -findOwningPackageForMain pkgs mainFile = - find (\pkg -> toFilePath (ghciPkgDir pkg) `isPrefixOf` toFilePath mainFile) pkgs - -renderScriptGhci :: [GhciPkgInfo] -> Maybe (Path Abs File) -> [Path Abs File] -> GhciScript -renderScriptGhci pkgs mainFile extraFiles = - let addPhase = mconcat $ fmap renderPkg pkgs - mainPhase = case mainFile of - Just path -> cmdAddFile path - Nothing -> mempty - modulePhase = cmdModule $ foldl' S.union S.empty (fmap ghciPkgModules pkgs) - in case getFileTargets pkgs <> extraFiles of - [] -> addPhase <> mainPhase <> modulePhase - fileTargets -> mconcat $ map cmdAddFile fileTargets - where - renderPkg pkg = cmdAdd (ghciPkgModules pkg) - -renderScriptIntero :: [GhciPkgInfo] -> Maybe (Path Abs File) -> [Path Abs File] -> GhciScript -renderScriptIntero pkgs mainFile extraFiles = - let addPhase = mconcat $ fmap renderPkg pkgs - mainPhase = case mainFile of - Just path -> - case findOwningPackageForMain pkgs path of - Just mainPkg -> cmdCdGhc (ghciPkgDir mainPkg) <> cmdAddFile path - Nothing -> cmdAddFile path - Nothing -> mempty - modulePhase = cmdModule $ foldl' S.union S.empty (fmap ghciPkgModules pkgs) - in case getFileTargets pkgs <> extraFiles of - [] -> addPhase <> mainPhase <> modulePhase - fileTargets -> mconcat $ map cmdAddFile fileTargets - where - renderPkg pkg = cmdCdGhc (ghciPkgDir pkg) - <> cmdAdd (ghciPkgModules pkg) +renderScript :: Bool -> [GhciPkgInfo] -> Maybe (Path Abs File) -> Bool -> [Path Abs File] -> GhciScript +renderScript isIntero pkgs mainFile onlyMain extraFiles = do + let cdPhase = case (isIntero, pkgs) of + -- If only loading one package, set the cwd properly. + -- Otherwise don't try. See + -- https://github.com/commercialhaskell/stack/issues/3309 + (True, [pkg]) -> cmdCdGhc (ghciPkgDir pkg) + _ -> mempty + addPhase = cmdAdd $ S.fromList (map Left allModules ++ addMain) + addMain = case mainFile of + Just path -> [Right path] + _ -> [] + modulePhase = cmdModule $ S.fromList allModules + allModules = concatMap (S.toList . ghciPkgModules) pkgs + case getFileTargets pkgs <> extraFiles of + [] -> + if onlyMain + then cdPhase <> if isJust mainFile then cmdAdd (S.fromList addMain) else mempty + else cdPhase <> addPhase <> modulePhase + fileTargets -> cmdAdd (S.fromList (map Right fileTargets)) -- Hacky check if module / main phase should be omitted. This should be -- improved if / when we have a better per-component load. @@ -442,30 +433,30 @@ -- is none, sometimes it's unambiguous, sometimes it's -- ambiguous. Warns and returns nothing if it's ambiguous. figureOutMainFile - :: (StackM r m) + :: HasRunner env => BuildOpts - -> Maybe (Map PackageName SimpleTarget) - -> [(PackageName, (Path Abs File, SimpleTarget))] + -> Maybe (Map PackageName Target) + -> [(PackageName, (Path Abs File, Target))] -> [GhciPkgInfo] - -> m (Maybe (Path Abs File)) + -> RIO env (Maybe (Path Abs File)) figureOutMainFile bopts mainIsTargets targets0 packages = do case candidates of [] -> return Nothing - [c@(_,_,fp)] -> do $logInfo ("Using main module: " <> renderCandidate c) + [c@(_,_,fp)] -> do logInfo ("Using main module: " <> renderCandidate c) return (Just fp) candidate:_ -> do borderedWarning $ do - $logWarn "The main module to load is ambiguous. Candidates are: " - forM_ (map renderCandidate candidates) $logWarn - $logWarn + logWarn "The main module to load is ambiguous. Candidates are: " + forM_ (map renderCandidate candidates) logWarn + logWarn "You can specify which one to pick by: " - $logWarn + logWarn (" * Specifying targets to stack ghci e.g. stack ghci " <> sampleTargetArg candidate) - $logWarn + logWarn (" * Specifying what the main is e.g. stack ghci " <> sampleMainIsArg candidate) - $logWarn + logWarn (" * Choosing from the candidate above [1.." <> T.pack (show $ length candidates) <> "]") liftIO userOption @@ -527,13 +518,13 @@ "--main-is " <> packageNameText pkg <> ":" <> renderComp comp getGhciPkgInfos - :: (StackM r m, HasEnvConfig r) + :: HasEnvConfig env => BuildOptsCLI -> SourceMap -> [PackageName] -> Maybe (Map PackageName (Set (Path Abs File))) - -> [(PackageName, (Path Abs File, SimpleTarget))] - -> m [GhciPkgInfo] + -> [(PackageName, (Path Abs File, Target))] + -> RIO env [GhciPkgInfo] getGhciPkgInfos buildOptsCLI sourceMap addPkgs mfileTargets localTargets = do menv <- getMinimalEnvOverride (installedMap, _, _, _) <- getInstalled @@ -550,7 +541,7 @@ -- | Make information necessary to load the given package in GHCi. makeGhciPkgInfo - :: (StackM r m, HasEnvConfig r) + :: HasEnvConfig env => BuildOptsCLI -> SourceMap -> InstalledMap @@ -559,8 +550,8 @@ -> Maybe (Map PackageName (Set (Path Abs File))) -> PackageName -> Path Abs File - -> SimpleTarget - -> m GhciPkgInfo + -> Target + -> RIO env GhciPkgInfo makeGhciPkgInfo buildOptsCLI sourceMap installedMap locals addPkgs mfileTargets name cabalfp target = do bopts <- view buildOptsL econfig <- view envConfigL @@ -575,7 +566,11 @@ , packageConfigCompilerVersion = compilerVersion , packageConfigPlatform = view platformL econfig } - (warnings,gpkgdesc) <- readPackageUnresolved cabalfp + -- TODO we've already parsed this information, otherwise we + -- wouldn't have figured out the cabalfp already. In the future: + -- retain that GenericPackageDescription in the relevant data + -- structures to avoid reparsing. + (gpkgdesc, _cabalfp) <- readPackageUnresolvedDir (parent cabalfp) True -- Source the package's *.buildinfo file created by configure if any. See -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters @@ -585,12 +580,18 @@ | hasDotBuildinfo = Just (parent cabalfp buildinfofp) | otherwise = Nothing mbuildinfo <- forM mbuildinfofp readDotBuildinfo - let pkg = + let pdp = resolvePackageDescription config gpkgdesc + pkg = packageFromPackageDescription config (C.genPackageFlags gpkgdesc) $ - maybe id C.updatePackageDescription mbuildinfo $ - resolvePackageDescription config gpkgdesc + maybe + pdp + (\bi -> + let PackageDescriptionPair x y = pdp + in PackageDescriptionPair + (C.updatePackageDescription bi x) + (C.updatePackageDescription bi y)) + mbuildinfo - mapM_ (printCabalFileWarning cabalfp) warnings (mods,files,opts) <- getPackageOpts (packageOpts pkg) sourceMap installedMap locals addPkgs cabalfp let filteredOpts = filterWanted opts filterWanted = M.filterWithKey (\k _ -> k `S.member` allWanted) @@ -612,10 +613,12 @@ -- 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 []) ++ +wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent +wantedPackageComponents _ (TargetComps cs) _ = cs +wantedPackageComponents bopts (TargetAll ProjectPackage) pkg = S.fromList $ + (case packageLibraries pkg of + NoLibraries -> [] + HasLibraries _names -> [CLib]) ++ -- FIXME. This ignores sub libraries and foreign libraries. Is that OK? map CExe (S.toList (packageExes pkg)) <> (if boptsTests bopts then map CTest (M.keys (packageTests pkg)) else []) <> (if boptsBenchmarks bopts then map CBench (S.toList (packageBenchmarks pkg)) else []) @@ -624,15 +627,15 @@ checkForIssues :: (MonadThrow m, MonadLogger m) => [GhciPkgInfo] -> m () checkForIssues pkgs = do unless (null issues) $ borderedWarning $ do - $logWarn "Warning: There are cabal settings for this project which may prevent GHCi from loading your code properly." - $logWarn "In some cases it can also load some projects which would otherwise fail to build." - $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" + logWarn "Warning: There are cabal settings for this project which may prevent GHCi from loading your code properly." + logWarn "In some cases it can also load some projects which would otherwise fail to build." + 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" @@ -686,20 +689,20 @@ borderedWarning :: MonadLogger m => m a -> m a borderedWarning f = do - $logWarn "" - $logWarn "* * * * * * * *" + logWarn "" + logWarn "* * * * * * * *" x <- f - $logWarn "* * * * * * * *" - $logWarn "" + logWarn "* * * * * * * *" + logWarn "" return x checkForDuplicateModules :: (MonadThrow m, MonadLogger m) => [GhciPkgInfo] -> m () checkForDuplicateModules pkgs = do unless (null duplicates) $ do borderedWarning $ do - $logWarn "The following modules are present in multiple packages:" + logWarn "The following modules are present in multiple packages:" forM_ duplicates $ \(mn, pns) -> do - $logWarn (" * " <> T.pack mn <> " (in " <> T.intercalate ", " (map packageNameText pns) <> ")") + logWarn (" * " <> T.pack mn <> " (in " <> T.intercalate ", " (map packageNameText pns) <> ")") throwM LoadingDuplicateModules where duplicates, allModules :: [(String, [PackageName])] @@ -708,6 +711,40 @@ M.toList $ M.fromListWith (++) $ concatMap (\pkg -> map ((, [ghciPkgName pkg]) . C.display) (S.toList (ghciPkgModules pkg))) pkgs +targetWarnings + :: HasRunner env + => Path Abs File + -> [(PackageName, (Path Abs File, Target))] + -> [PackageName] + -> Maybe (Map PackageName (Set (Path Abs File)), [Path Abs File]) + -> RIO env () +targetWarnings stackYaml localTargets nonLocalTargets mfileTargets = do + unless (null nonLocalTargets) $ + prettyWarnL + [ flow "Some targets" + , parens $ fillSep $ punctuate "," $ map (styleGood . display) nonLocalTargets + , flow "are not local packages, and so cannot be directly loaded." + , flow "In future versions of stack, this might be supported - see" + , styleUrl "https://github.com/commercialhaskell/stack/issues/1441" + , "." + , flow "It can still be useful to specify these, as they will be passed to ghci via -package flags." + ] + when (null localTargets && isNothing mfileTargets) $ + prettyWarn $ vsep + [ flow "No local targets specified, so ghci will not use any options from your package.yaml / *.cabal files." + , "" + , flow "Potential ways to resolve this:" + , bulletedList + [ fillSep + [ flow "If you want to use the package.yaml / *.cabal package in the current directory, use" + , styleShell "stack init" + , flow "to create a new stack.yaml." + ] + , flow "Add to the 'packages' field of" <+> display stackYaml + ] + , "" + ] + -- Adds in intermediate dependencies between ghci targets. Note that it -- will return a Lib component for these intermediate dependencies even -- if they don't have a library (but that's fine for the usage within @@ -718,8 +755,8 @@ getExtraLoadDeps :: Bool -> SourceMap - -> [(PackageName, (Path Abs File, SimpleTarget))] - -> [(PackageName, (Path Abs File, SimpleTarget))] + -> [(PackageName, (Path Abs File, Target))] + -> [(PackageName, (Path Abs File, Target))] getExtraLoadDeps loadAllDeps sourceMap targets = M.toList $ (\mp -> foldl' (flip M.delete) mp (map fst targets)) $ @@ -730,25 +767,25 @@ getDeps :: PackageName -> [PackageName] getDeps name = case M.lookup name sourceMap of - Just (PSLocal lp) -> M.keys (packageDeps (lpPackage lp)) + Just (PSFiles lp _) -> M.keys (packageDeps (lpPackage lp)) -- FIXME just Local? _ -> [] - go :: PackageName -> State (Map PackageName (Maybe (Path Abs File, SimpleTarget))) Bool + go :: PackageName -> State (Map PackageName (Maybe (Path Abs File, Target))) Bool go name = do cache <- get case (M.lookup name cache, M.lookup name sourceMap) of (Just (Just _), _) -> return True (Just Nothing, _) | not loadAllDeps -> return False - (_, Just (PSLocal lp)) -> do + (_, Just (PSFiles lp _)) -> do let deps = M.keys (packageDeps (lpPackage lp)) shouldLoad <- liftM or $ mapM go deps if shouldLoad then do - modify (M.insert name (Just (lpCabalFile lp, STLocalComps (S.singleton CLib)))) + modify (M.insert name (Just (lpCabalFile lp, TargetComps (S.singleton CLib)))) return True else do modify (M.insert name Nothing) return False - (_, Just PSUpstream{}) -> return loadAllDeps + (_, Just PSIndex{}) -> return loadAllDeps (_, _) -> return False preprocessCabalMacros :: MonadIO m => [GhciPkgInfo] -> Path Abs File -> m [String] @@ -773,21 +810,20 @@ ] #endif -unionSimpleTargets :: Ord k => Map k SimpleTarget -> Map k SimpleTarget -> Map k SimpleTarget -unionSimpleTargets = M.unionWith $ \l r -> +unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target +unionTargets = M.unionWith $ \l r -> case (l, r) of - (STUnknown, _) -> r - (STNonLocal, _) -> r - (STLocalComps sl, STLocalComps sr) -> STLocalComps (S.union sl sr) - (STLocalComps _, STLocalAll) -> STLocalAll - (STLocalComps _, _) -> l - (STLocalAll, _) -> STLocalAll + (TargetAll Dependency, _) -> r + (TargetComps sl, TargetComps sr) -> TargetComps (S.union sl sr) + (TargetComps _, TargetAll ProjectPackage) -> TargetAll ProjectPackage + (TargetComps _, _) -> l + (TargetAll ProjectPackage, _) -> TargetAll ProjectPackage -hasLocalComp :: (NamedComponent -> Bool) -> SimpleTarget -> Bool +hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool hasLocalComp p t = case t of - STLocalComps s -> any p (S.toList s) - STLocalAll -> True + TargetComps s -> any p (S.toList s) + TargetAll ProjectPackage -> True _ -> False @@ -816,7 +852,7 @@ -- FIXME: use compilerOptionsCabalFlag map ("--ghc-option=" ++) (concatMap (ghcOptions . snd) (ghciPkgOpts pkg)) , mapMaybe - (fmap toFilePath . stripDir pwd) + (fmap toFilePath . stripProperPrefix pwd) (S.toList (ghciPkgCFiles pkg) <> S.toList (ghciPkgModFiles pkg) <> [paths_foo | paths_foo_exists])) diff --git a/src/Stack/Ghci/Script.hs b/src/Stack/Ghci/Script.hs --- a/src/Stack/Ghci/Script.hs +++ b/src/Stack/Ghci/Script.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Stack.Ghci.Script @@ -5,7 +6,6 @@ , ModuleName , cmdAdd - , cmdAddFile , cmdCdGhc , cmdModule @@ -14,18 +14,14 @@ , scriptToFile ) where -import Control.Applicative import Data.ByteString.Lazy (ByteString) import Data.ByteString.Builder -import Data.Monoid import Data.List -import Data.Set (Set) import qualified Data.Set as S -import Data.Text (Text) import Data.Text.Encoding (encodeUtf8Builder) import Path -import Prelude -- Fix redundant imports warnings -import System.IO +import Stack.Prelude hiding (ByteString) +import System.IO (hSetBuffering, BufferMode (..), hSetBinaryMode) import Distribution.ModuleName hiding (toFilePath) @@ -36,18 +32,14 @@ (GhciScript xs) `mappend` (GhciScript ys) = GhciScript (ys <> xs) data GhciCommand - = Add (Set ModuleName) - | AddFile (Path Abs File) + = Add (Set (Either ModuleName (Path Abs File))) | CdGhc (Path Abs Dir) | Module (Set ModuleName) deriving (Show) -cmdAdd :: Set ModuleName -> GhciScript +cmdAdd :: Set (Either ModuleName (Path Abs File)) -> GhciScript cmdAdd = GhciScript . (:[]) . Add -cmdAddFile :: Path Abs File -> GhciScript -cmdAddFile = GhciScript . (:[]) . AddFile - cmdCdGhc :: Path Abs Dir -> GhciScript cmdCdGhc = GhciScript . (:[]) . CdGhc @@ -82,12 +74,10 @@ | S.null modules = mempty | otherwise = fromText ":add " - <> mconcat (intersperse (fromText " ") - $ (stringUtf8 . quoteFileName . mconcat . intersperse "." . components) <$> S.toAscList modules) + <> mconcat (intersperse (fromText " ") $ + fmap (stringUtf8 . quoteFileName . either (mconcat . intersperse "." . components) toFilePath) + (S.toAscList modules)) <> fromText "\n" - -commandToBuilder (AddFile path) = - fromText ":add " <> stringUtf8 (quoteFileName (toFilePath path)) <> fromText "\n" commandToBuilder (CdGhc path) = fromText ":cd-ghc " <> stringUtf8 (quoteFileName (toFilePath path)) <> fromText "\n" diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -7,74 +8,57 @@ ( hoogleCmd ) where -import Control.Exception -import Control.Monad.IO.Class -import Control.Monad.Logger +import Stack.Prelude import qualified Data.ByteString.Char8 as S8 +import Data.Char (isSpace) import Data.List (find) -import Data.Monoid import qualified Data.Set as Set +import qualified Data.Text as T import Lens.Micro -import Path -import Path.IO +import Path.IO hiding (findExecutable) import qualified Stack.Build import Stack.Fetch import Stack.Runners import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT import Stack.Types.Version import System.Exit -import System.Process.Read (resetExeCache, tryProcessStdout) +import System.Process.Read (resetExeCache, tryProcessStdout, findExecutable) import System.Process.Run -- | Hoogle command. hoogleCmd :: ([String],Bool,Bool) -> GlobalOpts -> IO () -hoogleCmd (args,setup,rebuild) go = withBuildConfig go pathToHaddocks +hoogleCmd (args,setup,rebuild) go = withBuildConfig go $ do + hooglePath <- ensureHoogleInPath + generateDbIfNeeded hooglePath + runHoogle hooglePath args where - pathToHaddocks :: StackT EnvConfig IO () - pathToHaddocks = do - hoogleIsInPath <- checkHoogleInPath - if hoogleIsInPath - then haddocksToDb - else do - if setup - then do - $logWarn - "Hoogle isn't installed or is too old. Automatically installing (use --no-setup to disable) ..." - installHoogle - haddocksToDb - else do - $logError - "Hoogle isn't installed or is too old. Not installing it due to --no-setup." - bail - haddocksToDb :: StackT EnvConfig IO () - haddocksToDb = do + generateDbIfNeeded :: Path Abs File -> RIO EnvConfig () + generateDbIfNeeded hooglePath = do databaseExists <- checkDatabaseExists if databaseExists && not rebuild - then runHoogle args + then return () else if setup || rebuild then do - $logWarn + logWarn (if rebuild then "Rebuilding database ..." else "No Hoogle database yet. Automatically building haddocks and hoogle database (use --no-setup to disable) ...") buildHaddocks - $logInfo "Built docs." - generateDb - $logInfo "Generated DB." - runHoogle args + logInfo "Built docs." + generateDb hooglePath + logInfo "Generated DB." else do - $logError + logError "No Hoogle database. Not building one due to --no-setup" bail - generateDb :: StackT EnvConfig IO () - generateDb = do + generateDb :: Path Abs File -> RIO EnvConfig () + generateDb hooglePath = do do dir <- hoogleRoot createDirIfMissing True dir - runHoogle ["generate", "--local"] - buildHaddocks :: StackT EnvConfig IO () + runHoogle hooglePath ["generate", "--local"] + buildHaddocks :: RIO EnvConfig () buildHaddocks = liftIO (catch @@ -90,12 +74,12 @@ defaultBuildOptsCLI)) (\(_ :: ExitCode) -> return ())) - installHoogle :: StackT EnvConfig IO () + hooglePackageName = $(mkPackageName "hoogle") + hoogleMinVersion = $(mkVersion "5.0") + hoogleMinIdent = + PackageIdentifier hooglePackageName hoogleMinVersion + installHoogle :: RIO EnvConfig () installHoogle = do - let hooglePackageName = $(mkPackageName "hoogle") - hoogleMinVersion = $(mkVersion "5.0") - hoogleMinIdent = - PackageIdentifier hooglePackageName hoogleMinVersion hooglePackageIdentifier <- do (_,_,resolved) <- resolvePackagesAllowMissing @@ -121,11 +105,11 @@ _ -> Left hoogleMinIdent) case hooglePackageIdentifier of Left{} -> - $logInfo + logInfo ("Minimum " <> packageIdentifierText hoogleMinIdent <> " is not in your index. Installing the minimum version.") Right ident -> - $logInfo + logInfo ("Minimum version is " <> packageIdentifierText hoogleMinIdent <> ". Found acceptable " <> packageIdentifierText ident <> @@ -151,8 +135,8 @@ case e of ExitSuccess -> resetExeCache menv _ -> throwIO e)) - runHoogle :: [String] -> StackT EnvConfig IO () - runHoogle hoogleArgs = do + runHoogle :: Path Abs File -> [String] -> RIO EnvConfig () + runHoogle hooglePath hoogleArgs = do config <- view configL menv <- liftIO $ configEnvOverride config envSettings dbpath <- hoogleDatabasePath @@ -160,27 +144,64 @@ runCmd Cmd { cmdDirectoryToRunIn = Nothing - , cmdCommandToRun = "hoogle" + , cmdCommandToRun = toFilePath hooglePath , cmdEnvOverride = menv , cmdCommandLineArguments = hoogleArgs ++ databaseArg } Nothing - bail :: StackT EnvConfig IO () + bail :: RIO EnvConfig a bail = liftIO (exitWith (ExitFailure (-1))) checkDatabaseExists = do path <- hoogleDatabasePath liftIO (doesFileExist path) - checkHoogleInPath = do + ensureHoogleInPath :: RIO EnvConfig (Path Abs File) + ensureHoogleInPath = do config <- view configL menv <- liftIO $ configEnvOverride config envSettings - result <- tryProcessStdout Nothing menv "hoogle" ["--numeric-version"] - case fmap (reads . S8.unpack) result of - Right [(ver :: Double,_)] -> return (ver >= 5.0) - _ -> return False + mhooglePath <- findExecutable menv "hoogle" + eres <- case mhooglePath of + Nothing -> return $ Left "Hoogle isn't installed." + Just hooglePath -> do + result <- tryProcessStdout Nothing menv (toFilePath hooglePath) ["--numeric-version"] + let unexpectedResult got = Left $ T.concat + [ "'" + , T.pack (toFilePath hooglePath) + , " --numeric-version' did not respond with expected value. Got: " + , got + ] + return $ case result of + Left err -> unexpectedResult $ T.pack (show err) + Right bs -> case parseVersionFromString (takeWhile (not . isSpace) (S8.unpack bs)) of + Nothing -> unexpectedResult $ T.pack (S8.unpack bs) + Just ver + | ver >= hoogleMinVersion -> Right hooglePath + | otherwise -> Left $ T.concat + [ "Installed Hoogle is too old, " + , T.pack (toFilePath hooglePath) + , " is version " + , versionText ver + , " but >= 5.0 is required." + ] + case eres of + Right hooglePath -> return hooglePath + Left err + | setup -> do + logWarn $ err <> " Automatically installing (use --no-setup to disable) ..." + installHoogle + mhooglePath' <- findExecutable menv "hoogle" + case mhooglePath' of + Just hooglePath -> return hooglePath + Nothing -> do + logWarn "Couldn't find hoogle in path after installing. This shouldn't happen, may be a bug." + bail + | otherwise -> do + logWarn $ err <> " Not installing it due to --no-setup." + bail envSettings = EnvSettings { esIncludeLocals = True , esIncludeGhcPackagePath = True , esStackExe = True , esLocaleUtf8 = False + , esKeepGhcRts = False } diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs --- a/src/Stack/IDE.hs +++ b/src/Stack/IDE.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -- | Functions for IDEs. @@ -10,44 +10,39 @@ , listTargets ) where -import Control.Monad.Logger -import Control.Monad.Reader import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T -import Stack.Build.Source (getLocalPackageViews) -import Stack.Build.Target (LocalPackageView(..)) import Stack.Config (getLocalPackages) -import Stack.Package (findOrGenerateCabalFile) +import Stack.Package (readPackageUnresolvedDir, gpdPackageName) +import Stack.Prelude import Stack.Types.Config import Stack.Types.Package import Stack.Types.PackageName -import Stack.Types.StackT -- | List the packages inside the current project. -listPackages :: (StackM env m, HasEnvConfig env) => m () +listPackages :: HasEnvConfig env => RIO env () listPackages = do -- TODO: Instead of setting up an entire EnvConfig only to look up the package directories, -- make do with a Config (and the Project inside) and use resolvePackageEntry to get -- the directory. - packageDirs <- liftM Map.keys getLocalPackages + packageDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages forM_ packageDirs $ \dir -> do - cabalfp <- findOrGenerateCabalFile dir - pkgName <- parsePackageNameFromFilePath cabalfp - ($logInfo . packageNameText) pkgName + (gpd, _) <- readPackageUnresolvedDir dir False + (logInfo . packageNameText) (gpdPackageName gpd) -- | List the targets in the current project. -listTargets :: (StackM env m, HasEnvConfig env) => m () +listTargets :: HasEnvConfig env => RIO env () listTargets = - do rawLocals <- getLocalPackageViews - $logInfo + do rawLocals <- lpProject <$> getLocalPackages + logInfo (T.intercalate "\n" (map renderPkgComponent (concatMap toNameAndComponent - (Map.toList (Map.map fst rawLocals))))) + (Map.toList rawLocals)))) where toNameAndComponent (pkgName,view') = map (pkgName, ) (Set.toList (lpvComponents view')) diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs --- a/src/Stack/Image.hs +++ b/src/Stack/Image.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} @@ -11,32 +12,26 @@ imgCmdName, imgDockerCmdName, imgOptsFromMonoid) where -import Control.Exception.Lifted hiding (finally) -import Control.Monad -import Control.Monad.Catch hiding (bracket) -import Control.Monad.IO.Class -import Control.Monad.Logger +import Stack.Prelude +import qualified Data.ByteString as B import Data.Char (toLower) import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Typeable -import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) import qualified Data.Text as T import Path import Path.Extra import Path.IO -import Stack.Constants +import Stack.Constants.Config import Stack.PrettyPrint import Stack.Types.Config import Stack.Types.Image -import Stack.Types.StackT import System.Process.Run -- | Stages the executables & additional content in a staging -- directory under '.stack-work' stageContainerImageArtifacts - :: (StackM env m, HasEnvConfig env) - => Maybe (Path Abs Dir) -> [Text] -> m () + :: HasEnvConfig env + => Maybe (Path Abs Dir) -> [Text] -> RIO env () stageContainerImageArtifacts mProjectRoot imageNames = do config <- view configL forM_ @@ -48,7 +43,7 @@ (\(idx,opts) -> do imageDir <- imageStagingDir (fromMaybeProjectRoot mProjectRoot) idx - ignoringAbsence (removeDirRecur imageDir) + liftIO (ignoringAbsence (removeDirRecur imageDir)) ensureDir imageDir stageExesInDir opts imageDir syncAddContentToDir opts imageDir) @@ -58,8 +53,8 @@ -- extended with an ENTRYPOINT specified for each `entrypoint` listed -- in the config file. createContainerImageFromStage - :: (StackM env m, HasConfig env) - => Maybe (Path Abs Dir) -> [Text] -> m () + :: HasConfig env + => Maybe (Path Abs Dir) -> [Text] -> RIO env () createContainerImageFromStage mProjectRoot imageNames = do config <- view configL forM_ @@ -84,22 +79,22 @@ -- | Stage all the Package executables in the usr/local/bin -- subdirectory of a temp directory. stageExesInDir - :: (StackM env m, HasEnvConfig env) - => ImageDockerOpts -> Path Abs Dir -> m () + :: HasEnvConfig env + => ImageDockerOpts -> Path Abs Dir -> RIO env () stageExesInDir opts dir = do srcBinPath <- fmap ( $(mkRelDir "bin")) installationRootLocal let destBinPath = dir $(mkRelDir "usr/local/bin") ensureDir destBinPath case imgDockerExecutables opts of Nothing -> do - $logInfo "" - $logInfo "Note: 'executables' not specified for a image container, so every executable in the project's local bin dir will be used." - mcontents <- forgivingAbsence $ listDir srcBinPath + logInfo "" + logInfo "Note: 'executables' not specified for a image container, so every executable in the project's local bin dir will be used." + mcontents <- liftIO $ forgivingAbsence $ listDir srcBinPath case mcontents of Just (files, dirs) - | not (null files) || not (null dirs) -> copyDirRecur srcBinPath destBinPath - _ -> $prettyWarn "The project's local bin dir contains no files, so no executables will be added to the docker image." - $logInfo "" + | not (null files) || not (null dirs) -> liftIO $ copyDirRecur srcBinPath destBinPath + _ -> prettyWarn "The project's local bin dir contains no files, so no executables will be added to the docker image." + logInfo "" Just exes -> forM_ @@ -112,8 +107,8 @@ -- | Add any additional files into the temp directory, respecting the -- (Source, Destination) mapping. syncAddContentToDir - :: (StackM env m, HasEnvConfig env) - => ImageDockerOpts -> Path Abs Dir -> m () + :: HasEnvConfig env + => ImageDockerOpts -> Path Abs Dir -> RIO env () syncAddContentToDir opts dir = do root <- view projectRootL let imgAdd = imgDockerAdd opts @@ -123,7 +118,7 @@ do sourcePath <- resolveDir root source let destFullPath = dir dropRoot destPath ensureDir destFullPath - copyDirRecur sourcePath destFullPath) + liftIO $ copyDirRecur sourcePath destFullPath) -- | Derive an image name from the project directory. imageName @@ -133,17 +128,17 @@ -- | Create a general purpose docker image from the temporary -- directory of executables & static content. createDockerImage - :: (StackM env m, HasConfig env) - => ImageDockerOpts -> Path Abs Dir -> m () + :: HasConfig env + => ImageDockerOpts -> Path Abs Dir -> RIO env () createDockerImage dockerConfig dir = do menv <- getMinimalEnvOverride case imgDockerBase dockerConfig of Nothing -> throwM StackImageDockerBaseUnspecifiedException Just base -> do liftIO - (writeFile + (B.writeFile (toFilePath (dir $(mkRelFile "Dockerfile"))) - (unlines ["FROM " ++ base, "ADD ./ /"])) + (encodeUtf8 (T.pack (unlines ["FROM " ++ base, "ADD ./ /"])))) let args = [ "build" , "-t" @@ -155,8 +150,8 @@ -- | Extend the general purpose docker image with entrypoints (if specified). extendDockerImageWithEntrypoint - :: (StackM env m, HasConfig env) - => ImageDockerOpts -> Path Abs Dir -> m () + :: HasConfig env + => ImageDockerOpts -> Path Abs Dir -> RIO env () extendDockerImageWithEntrypoint dockerConfig dir = do menv <- getMinimalEnvOverride let dockerImageName = @@ -171,14 +166,14 @@ eps (\ep -> do liftIO - (writeFile + (B.writeFile (toFilePath (dir $(mkRelFile "Dockerfile"))) - (unlines + (encodeUtf8 (T.pack (unlines [ "FROM " ++ dockerImageName , "ENTRYPOINT [\"/usr/local/bin/" ++ ep ++ "\"]" - , "CMD []"])) + , "CMD []"])))) callProcess (Cmd Nothing @@ -192,7 +187,7 @@ -- | Fail with friendly error if project root not set. fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir fromMaybeProjectRoot = - fromMaybe (throw StackImageCannotDetermineProjectRootException) + fromMaybe (impureThrow StackImageCannotDetermineProjectRootException) -- | The command name for dealing with images. imgCmdName diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -1,34 +1,26 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} module Stack.Init ( initProject , InitOpts (..) ) where -import Control.Exception (assert) -import Control.Exception.Safe (catchAny) -import Control.Monad -import Control.Monad.Catch (throwM) -import Control.Monad.IO.Class -import Control.Monad.Logger +import Stack.Prelude import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as L import qualified Data.Foldable as F -import Data.Function (on) import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IntMap import Data.List (intercalate, intersect, maximumBy) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import Data.Monoid +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Yaml as Yaml import qualified Distribution.PackageDescription as C @@ -42,26 +34,26 @@ import Stack.Config (getSnapshots, makeConcreteResolver) import Stack.Constants +import Stack.Snapshot (loadResolver) import Stack.Solver import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName +import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Resolver -import Stack.Types.StackT (StackM) -import Stack.Types.StringError import Stack.Types.Version import qualified System.FilePath as FP -- | Generate stack.yaml initProject - :: (StackM env m, HasConfig env, HasGHCVariant env) + :: (HasConfig env, HasGHCVariant env) => WhichSolverCmd -> Path Abs Dir -> InitOpts -> Maybe AbstractResolver - -> m () + -> RIO env () initProject whichCmd currDir initOpts mresolver = do let dest = currDir stackDotYaml @@ -77,15 +69,20 @@ dirs <- mapM (resolveDir' . T.unpack) (searchDirs initOpts) let noPkgMsg = "In order to init, you should have an existing .cabal \ \file. Please try \"stack new\" instead." - find = findCabalFiles (includeSubDirs initOpts) + find = findCabalDirs (includeSubDirs initOpts) dirs' = if null dirs then [currDir] else dirs - $logInfo "Looking for .cabal or package.yaml files to use to init the project." - cabalfps <- liftM concat $ mapM find dirs' - (bundle, dupPkgs) <- cabalPackagesCheck cabalfps noPkgMsg Nothing + logInfo "Looking for .cabal or package.yaml files to use to init the project." + cabaldirs <- (Set.toList . Set.unions) <$> mapM find dirs' + (bundle, dupPkgs) <- cabalPackagesCheck cabaldirs noPkgMsg Nothing - (r, flags, extraDeps, rbundle) <- getDefaultResolver whichCmd dest initOpts - mresolver bundle + (sd, flags, extraDeps, rbundle) <- getDefaultResolver whichCmd dest initOpts + mresolver bundle + -- Kind of inefficient, since we've already parsed this value. But + -- better to reparse in this one case than carry the unneeded data + -- around everywhere in the codebase. + resolver <- parseCustomLocation (Just (parent dest)) (void (sdResolver sd)) + let ignored = Map.difference bundle rbundle dupPkgMsg | dupPkgs /= [] = @@ -110,7 +107,7 @@ makeUserMsg msgs = let msg = concat msgs in if msg /= "" then - msg <> "You can suppress this message by removing it from \ + msg <> "You can omit this message by removing it from \ \stack.yaml\n" else "" @@ -120,15 +117,17 @@ p = Project { projectUserMsg = if userMsg == "" then Nothing else Just userMsg , projectPackages = pkgs - , projectExtraDeps = extraDeps - , projectFlags = PackageFlags (removeSrcPkgDefaultFlags gpds flags) - , projectResolver = r + , projectDependencies = map + (\(n, v) -> PLIndex $ PackageIdentifierRevision (PackageIdentifier n v) CFILatest) + (Map.toList extraDeps) + , projectFlags = removeSrcPkgDefaultFlags gpds flags + , projectResolver = resolver , projectCompiler = Nothing , projectExtraPackageDBs = [] } makeRelDir dir = - case stripDir currDir dir of + case stripProperPrefix currDir dir of Nothing | currDir == dir -> "." | otherwise -> assert False $ toFilePathNoTrailingSep dir @@ -137,35 +136,31 @@ makeRel = fmap toFilePath . makeRelativeToCurrentDir pkgs = map toPkg $ Map.elems (fmap (parent . fst) rbundle) - toPkg dir = PackageEntry - { peExtraDepMaybe = Nothing - , peLocation = PLFilePath $ makeRelDir dir - , peSubdirs = [] - } + toPkg dir = PLFilePath $ makeRelDir dir indent t = T.unlines $ fmap (" " <>) (T.lines t) - $logInfo $ "Initialising configuration using resolver: " <> resolverName r - $logInfo $ "Total number of user packages considered: " + logInfo $ "Initialising configuration using resolver: " <> sdResolverName sd + logInfo $ "Total number of user packages considered: " <> T.pack (show (Map.size bundle + length dupPkgs)) when (dupPkgs /= []) $ do - $logWarn $ "Warning! Ignoring " + logWarn $ "Warning! Ignoring " <> T.pack (show $ length dupPkgs) <> " duplicate packages:" rels <- mapM makeRel dupPkgs - $logWarn $ indent $ showItems rels + logWarn $ indent $ showItems rels when (Map.size ignored > 0) $ do - $logWarn $ "Warning! Ignoring " + logWarn $ "Warning! Ignoring " <> T.pack (show $ Map.size ignored) <> " packages due to dependency conflicts:" rels <- mapM makeRel (Map.elems (fmap fst ignored)) - $logWarn $ indent $ showItems rels + logWarn $ indent $ showItems rels when (Map.size extraDeps > 0) $ do - $logWarn $ "Warning! " <> T.pack (show $ Map.size extraDeps) + logWarn $ "Warning! " <> T.pack (show $ Map.size extraDeps) <> " external dependencies were added." - $logInfo $ + logInfo $ (if exists then "Overwriting existing configuration file: " else "Writing configuration to file: ") <> T.pack reldest @@ -174,7 +169,7 @@ $ renderStackYaml p (Map.elems $ fmap (makeRelDir . parent . fst) ignored) (map (makeRelDir . parent) dupPkgs) - $logInfo "All done." + logInfo "All done." -- | Render a stack.yaml file with comments, see: -- https://github.com/commercialhaskell/stack/issues/226 @@ -192,15 +187,25 @@ <> B.byteString footerHelp goComment o (name, comment) = - case HM.lookup name o of + case (convert <$> HM.lookup name o) <|> nonPresentValue name of Nothing -> assert (name == "user-message") mempty Just v -> B.byteString comment <> B.byteString "\n" <> - B.byteString (Yaml.encode $ Yaml.object [(name, v)]) <> + v <> if name == "packages" then commentedPackages else "" <> B.byteString "\n" + where + convert v = B.byteString (Yaml.encode $ Yaml.object [(name, v)]) + -- Some fields in stack.yaml are optional and may not be + -- generated. For these, we provided commented out dummy + -- values to go along with the comments. + nonPresentValue "extra-deps" = Just "# extra-deps: []\n" + nonPresentValue "flags" = Just "# flags: {}\n" + nonPresentValue "extra-package-dbs" = Just "# extra-package-dbs: []\n" + nonPresentValue _ = Nothing + commentLine l | null l = "#" | otherwise = "# " ++ l commentHelp = BC.pack . intercalate "\n" . map commentLine @@ -288,7 +293,7 @@ footerHelp = let major = toCabalVersion - $ toMajorVersion $ fromCabalVersion Meta.version + $ toMajorVersion $ fromCabalVersion $ C.mkVersion' Meta.version in commentHelp [ "Control whether we use the GHC we find on the path" , "system-ghc: true" @@ -310,36 +315,36 @@ , "compiler-check: newer-minor" ] -getSnapshots' :: (StackM env m, HasConfig env) - => m Snapshots +getSnapshots' :: HasConfig env => RIO env Snapshots getSnapshots' = do getSnapshots `catchAny` \e -> do - $logError $ + logError $ "Unable to download snapshot list, and therefore could " <> "not generate a stack.yaml file automatically" - $logError $ + logError $ "This sometimes happens due to missing Certificate Authorities " <> "on your system. For more information, see:" - $logError "" - $logError " https://github.com/commercialhaskell/stack/issues/234" - $logError "" - $logError "You can try again, or create your stack.yaml file by hand. See:" - $logError "" - $logError " http://docs.haskellstack.org/en/stable/yaml_configuration/" - $logError "" - $logError $ "Exception was: " <> T.pack (show e) - errorString "" + logError "" + logError " https://github.com/commercialhaskell/stack/issues/234" + logError "" + logError "You can try again, or create your stack.yaml file by hand. See:" + logError "" + logError " http://docs.haskellstack.org/en/stable/yaml_configuration/" + logError "" + logError $ "Exception was: " <> T.pack (show e) + throwString "" -- | Get the default resolver value getDefaultResolver - :: (StackM env m, HasConfig env, HasGHCVariant env) + :: (HasConfig env, HasGHCVariant env) => WhichSolverCmd -> Path Abs File -- ^ stack.yaml -> InitOpts -> Maybe AbstractResolver -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description - -> m ( Resolver + -> RIO env + ( SnapshotDef , Map PackageName (Map FlagName Bool) , Map PackageName Version , Map PackageName (Path Abs File, C.GenericPackageDescription)) @@ -347,61 +352,66 @@ -- , Flags for src packages and extra deps -- , Extra dependencies -- , Src packages actually considered) -getDefaultResolver whichCmd stackYaml initOpts mresolver bundle = - maybe selectSnapResolver makeConcreteResolver mresolver - >>= getWorkingResolverPlan whichCmd stackYaml initOpts bundle +getDefaultResolver whichCmd stackYaml initOpts mresolver bundle = do + sd <- maybe selectSnapResolver (makeConcreteResolver (Just root) >=> loadResolver) mresolver + getWorkingResolverPlan whichCmd stackYaml initOpts bundle sd where + root = parent stackYaml -- TODO support selecting best across regular and custom snapshots selectSnapResolver = do let gpds = Map.elems (fmap snd bundle) snaps <- fmap getRecommendedSnapshots getSnapshots' - (s, r) <- selectBestSnapshot gpds snaps + (s, r) <- selectBestSnapshot (parent stackYaml) gpds snaps case r of BuildPlanCheckFail {} | not (omitPackages initOpts) -> throwM (NoMatchingSnapshot whichCmd snaps) - _ -> return $ ResolverSnapshot s + _ -> return s getWorkingResolverPlan - :: (StackM env m, HasConfig env, HasGHCVariant env) + :: (HasConfig env, HasGHCVariant env) => WhichSolverCmd -> Path Abs File -- ^ stack.yaml -> InitOpts -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description - -> Resolver - -> m ( Resolver + -> SnapshotDef + -> RIO env + ( SnapshotDef , Map PackageName (Map FlagName Bool) , Map PackageName Version , Map PackageName (Path Abs File, C.GenericPackageDescription)) - -- ^ ( Resolver + -- ^ ( SnapshotDef -- , Flags for src packages and extra deps -- , Extra dependencies -- , Src packages actually considered) -getWorkingResolverPlan whichCmd stackYaml initOpts bundle resolver = do - $logInfo $ "Selected resolver: " <> resolverName resolver +getWorkingResolverPlan whichCmd stackYaml initOpts bundle sd = do + logInfo $ "Selected resolver: " <> sdResolverName sd go bundle where go info = do - eres <- checkBundleResolver whichCmd stackYaml initOpts info resolver + eres <- checkBundleResolver whichCmd stackYaml initOpts info sd -- if some packages failed try again using the rest case eres of - Right (f, edeps)-> return (resolver, f, edeps, info) + Right (f, edeps)-> return (sd, f, edeps, info) Left ignored | Map.null available -> do - $logWarn "*** Could not find a working plan for any of \ + logWarn "*** Could not find a working plan for any of \ \the user packages.\nProceeding to create a \ \config anyway." - return (resolver, Map.empty, Map.empty, Map.empty) + return (sd, Map.empty, Map.empty, Map.empty) | otherwise -> do when (Map.size available == Map.size info) $ error "Bug: No packages to ignore" if length ignored > 1 then do - $logWarn "*** Ignoring packages:" - $logWarn $ indent $ showItems ignored + logWarn "*** Ignoring packages:" + logWarn $ indent $ showItems ignored else - $logWarn $ "*** Ignoring package: " - <> T.pack (packageNameString (head ignored)) + logWarn $ "*** Ignoring package: " + <> T.pack (packageNameString + (case ignored of + [] -> error "getWorkingResolverPlan.head" + x:_ -> x)) go available where @@ -410,41 +420,51 @@ available = Map.filterWithKey isAvailable info checkBundleResolver - :: (StackM env m, HasConfig env, HasGHCVariant env) + :: (HasConfig env, HasGHCVariant env) => WhichSolverCmd -> Path Abs File -- ^ stack.yaml -> InitOpts -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description - -> Resolver - -> m (Either [PackageName] ( Map PackageName (Map FlagName Bool) + -> SnapshotDef + -> RIO env + (Either [PackageName] ( Map PackageName (Map FlagName Bool) , Map PackageName Version)) -checkBundleResolver whichCmd stackYaml initOpts bundle resolver = do - result <- checkResolverSpec gpds Nothing resolver +checkBundleResolver whichCmd stackYaml initOpts bundle sd = do + result <- checkSnapBuildPlanActual (parent stackYaml) gpds Nothing sd case result of BuildPlanCheckOk f -> return $ Right (f, Map.empty) - BuildPlanCheckPartial f e - | needSolver resolver initOpts -> do - warnPartial result - solve f - | omitPackages initOpts -> do - warnPartial result - $logWarn "*** Omitting packages with unsatisfied dependencies" - return $ Left $ failedUserPkgs e - | otherwise -> throwM $ ResolverPartial whichCmd resolver (show result) + BuildPlanCheckPartial f e -> do + shouldUseSolver <- case (resolver, initOpts) of + (_, InitOpts { useSolver = True }) -> return True + (ResolverCompiler _, _) -> do + logInfo "Using solver because a compiler resolver was specified." + return True + _ -> return False + if shouldUseSolver + then do + warnPartial result + solve f + else if omitPackages initOpts + then do + warnPartial result + logWarn "*** Omitting packages with unsatisfied dependencies" + return $ Left $ failedUserPkgs e + else throwM $ ResolverPartial whichCmd (sdResolverName sd) (show result) BuildPlanCheckFail _ e _ | omitPackages initOpts -> do - $logWarn $ "*** Resolver compiler mismatch: " - <> resolverName resolver - $logWarn $ indent $ T.pack $ show result + logWarn $ "*** Resolver compiler mismatch: " + <> sdResolverName sd + logWarn $ indent $ T.pack $ show result return $ Left $ failedUserPkgs e - | otherwise -> throwM $ ResolverMismatch whichCmd resolver (show result) + | otherwise -> throwM $ ResolverMismatch whichCmd (sdResolverName sd) (show result) where + resolver = sdResolver sd indent t = T.unlines $ fmap (" " <>) (T.lines t) warnPartial res = do - $logWarn $ "*** Resolver " <> resolverName resolver + logWarn $ "*** Resolver " <> sdResolverName sd <> " will need external packages: " - $logWarn $ indent $ T.pack $ show res + logWarn $ indent $ T.pack $ show res failedUserPkgs e = Map.keys $ Map.unions (Map.elems (fmap deNeededBy e)) @@ -454,7 +474,7 @@ srcConstraints = mergeConstraints (gpdPackages gpds) flags eresult <- solveResolverSpec stackYaml cabalDirs - (resolver, srcConstraints, Map.empty) + (sd, srcConstraints, Map.empty) case eresult of Right (src, ext) -> return $ Right (fmap snd (Map.union src ext), fmap fst ext) @@ -471,16 +491,16 @@ -- set of packages. findOneIndependent packages flags = do platform <- view platformL - (compiler, _) <- getResolverConstraints stackYaml resolver - let getGpd pkg = snd (fromJust (Map.lookup pkg bundle)) - getFlags pkg = fromJust (Map.lookup pkg flags) + (compiler, _) <- getResolverConstraints Nothing stackYaml sd + let getGpd pkg = snd (fromMaybe (error "findOneIndependent: getGpd") (Map.lookup pkg bundle)) + getFlags pkg = fromMaybe (error "fromOneIndependent: getFlags") (Map.lookup pkg flags) deps pkg = gpdPackageDeps (getGpd pkg) compiler platform (getFlags pkg) allDeps = concatMap (Map.keys . deps) packages isIndependent pkg = pkg `notElem` allDeps -- prefer to reject packages in deeper directories - path pkg = fst (fromJust (Map.lookup pkg bundle)) + path pkg = fst (fromMaybe (error "findOneIndependent: path") (Map.lookup pkg bundle)) pathlen = length . FP.splitPath . toFilePath . path maxPathlen = maximumBy (compare `on` pathlen) @@ -494,10 +514,6 @@ , " - Add extra dependencies to guide solver.\n" , " - Update external packages with 'stack update' and try again.\n" ] - - needSolver _ InitOpts {useSolver = True} = True - needSolver (ResolverCompiler _) _ = True - needSolver _ _ = False getRecommendedSnapshots :: Snapshots -> NonEmpty SnapName getRecommendedSnapshots snapshots = diff --git a/src/Stack/New.hs b/src/Stack/New.hs --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -18,27 +19,17 @@ , listTemplates) where -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Logger +import Stack.Prelude import Control.Monad.Trans.Writer.Strict import Data.Aeson import Data.Aeson.Types import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB import Data.Conduit -import Data.Foldable (asum) import qualified Data.HashMap.Strict as HM import Data.List -import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import Data.Maybe.Extra (mapMaybeM) -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as S -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T (lenientDecode) @@ -46,17 +37,15 @@ import qualified Data.Text.Lazy as LT import Data.Time.Calendar import Data.Time.Clock -import Data.Typeable import qualified Data.Yaml as Yaml import Network.HTTP.Download import Network.HTTP.Simple import Path import Path.IO -import Prelude import Stack.Constants +import Stack.Constants.Config import Stack.Types.Config import Stack.Types.PackageName -import Stack.Types.StackT import Stack.Types.TemplateName import System.Process.Run import Text.Hastache @@ -80,9 +69,7 @@ } -- | Create a new project with the given options. -new - :: (StackM env m, HasConfig env) - => NewOpts -> Bool -> m (Path Abs Dir) +new :: HasConfig env => NewOpts -> Bool -> RIO env (Path Abs Dir) new opts forceOverwrite = do when (newOptsProjectName opts `elem` wiredInPackages) $ throwM $ Can'tUseWiredInName (newOptsProjectName opts) @@ -119,7 +106,7 @@ LocalTemp -> "Loading local" RemoteTemp -> "Downloading" in - $logInfo + logInfo (loading <> " template \"" <> templateName template <> "\" to create project \"" <> packageNameText project <> @@ -132,8 +119,10 @@ -- | Download and read in a template's text content. loadTemplate - :: forall env m. (StackM env m, HasConfig env) - => TemplateName -> (TemplateFrom -> m ()) -> m Text + :: forall env. HasConfig env + => TemplateName + -> (TemplateFrom -> RIO env ()) + -> RIO env Text loadTemplate name logIt = do templateDir <- view $ configL.to templatesDir case templatePath name of @@ -154,9 +143,9 @@ Nothing -> throwM e ) where - loadLocalFile :: Path b File -> m Text + loadLocalFile :: Path b File -> RIO env Text loadLocalFile path = do - $logDebug ("Opening local template: \"" <> T.pack (toFilePath path) + logDebug ("Opening local template: \"" <> T.pack (toFilePath path) <> "\"") exists <- doesFileExist path if exists @@ -164,7 +153,7 @@ else throwM (FailedToLoadTemplate name (toFilePath path)) relRequest :: MonadThrow n => Path Rel File -> n Request relRequest rel = parseRequest (defaultTemplateUrl <> "/" <> toFilePath rel) - downloadTemplate :: Request -> Path Abs File -> m Text + downloadTemplate :: Request -> Path Abs File -> RIO env Text downloadTemplate req path = do logIt RemoteTemp _ <- @@ -176,13 +165,13 @@ -- | Apply and unpack a template into a directory. applyTemplate - :: (StackM env m, HasConfig env) + :: HasConfig env => PackageName -> TemplateName -> Map Text Text -> Path Abs Dir -> Text - -> m (Map (Path Abs File) LB.ByteString) + -> RIO env (Map (Path Abs File) LB.ByteString) applyTemplate project template nonceParams dir templateText = do config <- view configL currentYear <- do @@ -205,7 +194,7 @@ templateText (mkStrContextM (contextFunction context))) unless (S.null missingKeys) - ($logInfo ("\n" <> T.pack (show (MissingParameters project template missingKeys (configUserConfigPath config))) <> "\n")) + (logInfo ("\n" <> T.pack (show (MissingParameters project template missingKeys (configUserConfigPath config))) <> "\n")) files :: Map FilePath LB.ByteString <- catch (execWriterT $ yield (T.encodeUtf8 (LT.toStrict applied)) $$ @@ -262,8 +251,8 @@ -- | Run any initialization functions, such as Git. runTemplateInits - :: (StackM env m, HasConfig env) - => Path Abs Dir -> m () + :: HasConfig env + => Path Abs Dir -> RIO env () runTemplateInits dir = do menv <- getMinimalEnvOverride config <- view configL @@ -272,10 +261,10 @@ Just Git -> catch (callProcess $ Cmd (Just dir) "git" menv ["init"]) (\(_ :: ProcessExitedUnsuccessfully) -> - $logInfo "git init failed to run, ignoring ...") + logInfo "git init failed to run, ignoring ...") -- | Display the set of templates accompanied with description if available. -listTemplates :: StackM env m => m () +listTemplates :: HasLogFunc env => RIO env () listTemplates = do templates <- getTemplates templateInfo <- getTemplateInfo @@ -292,7 +281,7 @@ else mapM_ (liftIO . T.putStrLn . templateName) (S.toList templates) -- | Get the set of templates. -getTemplates :: StackM env m => m (Set TemplateName) +getTemplates :: HasLogFunc env => RIO env (Set TemplateName) getTemplates = do req <- liftM setGithubHeaders (parseUrlThrow defaultTemplatesList) resp <- catch (httpJSON req) (throwM . FailedToDownloadTemplates) @@ -300,13 +289,13 @@ 200 -> return $ unTemplateSet $ getResponseBody resp code -> throwM (BadTemplatesResponse code) -getTemplateInfo :: StackM env m => m (Map Text TemplateInfo) +getTemplateInfo :: HasLogFunc env => RIO env (Map Text TemplateInfo) getTemplateInfo = do req <- liftM setGithubHeaders (parseUrlThrow defaultTemplateInfoUrl) resp <- catch (liftM Right $ httpLbs req) (\(ex :: HttpException) -> return . Left $ "Failed to download template info. The HTTP error was: " <> show ex) case resp >>= is200 of Left err -> do - liftIO . putStrLn $ err + logInfo $ T.pack err return M.empty Right resp' -> case Yaml.decodeEither (LB.toStrict $ getResponseBody resp') :: Either String Object of diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -- | Run commands in a nix-shell module Stack.Nix @@ -11,21 +12,11 @@ ,nixHelpOptName ) where -import Control.Arrow ((***)) -import Control.Exception (Exception,throw) -import Control.Monad hiding (mapM) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger (logDebug) -import Data.Maybe -import Data.Monoid +import Stack.Prelude import qualified Data.Text as T -import Data.Traversable -import Data.Typeable (Typeable) import Data.Version (showVersion) -import Path import Path.IO import qualified Paths_stack as Meta -import Prelude hiding (mapM) -- Fix redundant import warnings import Stack.Config (getInNixShell, getInContainer) import Stack.Config.Nix (nixCompiler) import Stack.Constants (platformVariantEnvVar,inNixShellEnvVar,inContainerEnvVar) @@ -33,9 +24,8 @@ import Stack.Types.Config import Stack.Types.Docker import Stack.Types.Nix +import Stack.Types.Runner import Stack.Types.Compiler -import Stack.Types.Internal -import Stack.Types.StackT import System.Environment (getArgs,getExecutablePath,lookupEnv) import qualified System.FilePath as F import System.Process.Read (getEnvOverride) @@ -43,11 +33,11 @@ -- | If Nix is enabled, re-runs the currently running OS command in a Nix container. -- Otherwise, runs the inner action. reexecWithOptionalShell - :: (StackM env m, HasConfig env) + :: HasConfig env => Maybe (Path Abs Dir) - -> IO CompilerVersion + -> IO (CompilerVersion 'CVWanted) -> IO () - -> m () + -> RIO env () reexecWithOptionalShell mprojectRoot getCompilerVersion inner = do config <- view configL inShell <- getInNixShell @@ -67,11 +57,11 @@ runShellAndExit - :: (StackM env m, HasConfig env) + :: HasConfig env => Maybe (Path Abs Dir) - -> IO CompilerVersion - -> m (String, [String]) - -> m () + -> IO (CompilerVersion 'CVWanted) + -> RIO env (String, [String]) + -> RIO env () runShellAndExit mprojectRoot getCompilerVersion getCmdArgs = do config <- view configL envOverride <- getEnvOverride (configPlatform config) @@ -81,9 +71,9 @@ nixInitFile (configNix config) compilerVersion <- liftIO getCompilerVersion inContainer <- getInContainer + ghc <- either throwIO return $ nixCompiler compilerVersion let pkgsInConfig = nixPackages (configNix config) - ghc = nixCompiler compilerVersion - pkgs = pkgsInConfig ++ [ghc, "git"] + pkgs = pkgsInConfig ++ [ghc, "git", "gcc"] pkgsStr = "[" <> T.intercalate " " pkgs <> "]" pureShell = nixPureShell (configNix config) addGCRoots = nixAddGCRoots (configNix config) @@ -123,8 +113,8 @@ -- Using --run instead of --command so we cannot -- end up in the nix-shell if stack build is Ctrl-C'd pathVar <- liftIO $ lookupEnv "PATH" - $logDebug $ "PATH is: " <> T.pack (show pathVar) - $logDebug $ + logDebug $ "PATH is: " <> T.pack (show pathVar) + logDebug $ "Using a nix-shell environment " <> (case mshellFile of Just path -> "from file: " <> T.pack (toFilePath path) Nothing -> "with nix packages: " <> T.intercalate ", " pkgs) @@ -139,7 +129,7 @@ -- | Fail with friendly error if project root not set. fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir -fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRoot) +fromMaybeProjectRoot = fromMaybe (impureThrow CannotDetermineProjectRoot) -- | Command-line argument for "nix" nixCmdName :: String diff --git a/src/Stack/Options/BenchParser.hs b/src/Stack/Options/BenchParser.hs --- a/src/Stack/Options/BenchParser.hs +++ b/src/Stack/Options/BenchParser.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Stack.Options.BenchParser where -import Data.Monoid.Extra import Options.Applicative import Options.Applicative.Builder.Extra +import Stack.Prelude import Stack.Options.Utils import Stack.Types.Config diff --git a/src/Stack/Options/BuildMonoidParser.hs b/src/Stack/Options/BuildMonoidParser.hs --- a/src/Stack/Options/BuildMonoidParser.hs +++ b/src/Stack/Options/BuildMonoidParser.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.BuildMonoidParser where -import Data.Monoid.Extra +import qualified Data.Text as T import Options.Applicative import Options.Applicative.Builder.Extra import Stack.Build (splitObjsWarning) +import Stack.Prelude import Stack.Options.BenchParser import Stack.Options.TestParser import Stack.Options.HaddockParser @@ -16,9 +18,10 @@ libProfiling <*> exeProfiling <*> libStripping <*> exeStripping <*> haddock <*> haddockOptsParser hideBool <*> openHaddocks <*> haddockDeps <*> haddockInternal <*> - haddockHyperlinkSource <*> copyBins <*> preFetch <*> keepGoing <*> - forceDirty <*> tests <*> testOptsParser hideBool <*> benches <*> - benchOptsParser hideBool <*> reconfigure <*> cabalVerbose <*> splitObjs + haddockHyperlinkSource <*> copyBins <*> copyCompilerTool <*> + preFetch <*> keepGoing <*> forceDirty <*> + tests <*> testOptsParser hideBool <*> benches <*> + benchOptsParser hideBool <*> reconfigure <*> cabalVerbose <*> splitObjs <*> skipComponents where hideBool = hide0 /= BuildCmdGlobalOpts hide = @@ -60,7 +63,6 @@ \debuggers/profiling tools/other utilities that use \ \debugging symbols." <> hideExceptGhci) - libProfiling = firstBoolFlags "library-profiling" @@ -108,6 +110,11 @@ "copy-bins" "copying binaries to the local-bin-path (see 'stack path')" hide + copyCompilerTool = + firstBoolFlags + "copy-compiler-tool" + "copying binaries of targets to compiler-tools-bin (see 'stack path')" + hide keepGoing = firstBoolFlags "keep-going" @@ -148,3 +155,10 @@ "split-objs" ("Enable split-objs, to reduce output size (at the cost of build time). " ++ splitObjsWarning) hide + skipComponents = many + (fmap + T.pack + (strOption + (long "skip" <> + help "Skip given component, can be specified multiple times" <> + hide))) diff --git a/src/Stack/Options/BuildParser.hs b/src/Stack/Options/BuildParser.hs --- a/src/Stack/Options/BuildParser.hs +++ b/src/Stack/Options/BuildParser.hs @@ -1,10 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Stack.Options.BuildParser where import qualified Data.Map as Map -import Data.Monoid.Extra -import Data.Text (Text) import Data.Version (showVersion) import Options.Applicative import Options.Applicative.Args @@ -12,6 +11,7 @@ import Paths_stack as Meta import Stack.Options.Completion import Stack.Options.PackageParser (readFlag) +import Stack.Prelude import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.PackageName diff --git a/src/Stack/Options/CleanParser.hs b/src/Stack/Options/CleanParser.hs --- a/src/Stack/Options/CleanParser.hs +++ b/src/Stack/Options/CleanParser.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.CleanParser where -import Data.Monoid.Extra import Options.Applicative import Stack.Clean (CleanOpts (..)) +import Stack.Prelude import Stack.Types.PackageName -- | Command-line parser for the clean command. diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs --- a/src/Stack/Options/Completion.hs +++ b/src/Stack/Options/Completion.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -9,7 +10,6 @@ , projectExeCompleter ) where -import Control.Monad.Logger (LogLevel (LevelOther)) import Data.Char (isSpace) import Data.List (isPrefixOf) import Data.List.Extra (nubOrd) @@ -18,18 +18,18 @@ import qualified Data.Set as Set import qualified Data.Text as T import qualified Distribution.PackageDescription as C +import qualified Distribution.Types.UnqualComponentName as C import Options.Applicative import Options.Applicative.Builder.Extra -import Stack.Build.Target (LocalPackageView(..)) -import Stack.Build.Source (getLocalPackageViews) +import Stack.Config (getLocalPackages) import Stack.Options.GlobalParser (globalOptsFromMonoid) import Stack.Runners (loadConfigWithOpts) +import Stack.Prelude hiding (lift) import Stack.Setup import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.Package import Stack.Types.PackageName -import Stack.Types.StackT import System.Process (readProcess) import Language.Haskell.TH.Syntax (runIO, lift) @@ -50,7 +50,7 @@ -- changes to optparse-applicative. buildConfigCompleter - :: (String -> StackT EnvConfig IO [String]) + :: (String -> RIO EnvConfig [String]) -> Completer buildConfigCompleter inner = mkCompleter $ \inputRaw -> do let input = unescapeBashArg inputRaw @@ -60,44 +60,42 @@ _ -> do let go = (globalOptsFromMonoid False mempty) { globalLogLevel = LevelOther "silent" } - lc <- loadConfigWithOpts go - bconfig <- runStackTGlobal () go $ - lcLoadBuildConfig lc (globalCompiler go) - envConfig <- - runStackTGlobal bconfig go (setupEnv Nothing) - runStackTGlobal envConfig go (inner input) + loadConfigWithOpts go $ \lc -> do + bconfig <- liftIO $ lcLoadBuildConfig lc (globalCompiler go) + envConfig <- runRIO bconfig (setupEnv Nothing) + runRIO envConfig (inner input) targetCompleter :: Completer targetCompleter = buildConfigCompleter $ \input -> do - lpvs <- getLocalPackageViews + lpvs <- fmap lpProject getLocalPackages return $ filter (input `isPrefixOf`) $ concatMap allComponentNames (Map.toList lpvs) where - allComponentNames (name, (lpv, _)) = + allComponentNames (name, lpv) = map (T.unpack . renderPkgComponent . (name,)) (Set.toList (lpvComponents lpv)) flagCompleter :: Completer flagCompleter = buildConfigCompleter $ \input -> do - lpvs <- getLocalPackageViews + lpvs <- fmap lpProject getLocalPackages bconfig <- view buildConfigL let wildcardFlags = nubOrd - $ concatMap (\(name, (_, gpd)) -> - map (\fl -> "*:" ++ flagString name fl) (C.genPackageFlags gpd)) + $ concatMap (\(name, lpv) -> + map (\fl -> "*:" ++ flagString name fl) (C.genPackageFlags (lpvGPD lpv))) $ Map.toList lpvs normalFlags - = concatMap (\(name, (_, gpd)) -> + = concatMap (\(name, lpv) -> map (\fl -> packageNameString name ++ ":" ++ flagString name fl) - (C.genPackageFlags gpd)) + (C.genPackageFlags (lpvGPD lpv))) $ Map.toList lpvs flagString name fl = - case C.flagName fl of - C.FlagName flname -> (if flagEnabled name fl then "-" else "") ++ flname + let flname = C.unFlagName $ C.flagName fl + in (if flagEnabled name fl then "-" else "") ++ flname flagEnabled name fl = fromMaybe (C.flagDefault fl) $ Map.lookup (fromCabalFlagName (C.flagName fl)) $ - Map.findWithDefault Map.empty name (unPackageFlags (bcFlags bconfig)) + Map.findWithDefault Map.empty name (bcFlags bconfig) return $ filter (input `isPrefixOf`) $ case input of ('*' : ':' : _) -> wildcardFlags @@ -106,9 +104,9 @@ projectExeCompleter :: Completer projectExeCompleter = buildConfigCompleter $ \input -> do - lpvs <- getLocalPackageViews + lpvs <- fmap lpProject getLocalPackages return $ filter (input `isPrefixOf`) $ nubOrd $ - concatMap (\(_, (_, gpd)) -> map fst (C.condExecutables gpd)) $ + concatMap (\(_, lpv) -> map (C.unUnqualComponentName . fst) (C.condExecutables (lpvGPD lpv))) $ Map.toList lpvs diff --git a/src/Stack/Options/ConfigParser.hs b/src/Stack/Options/ConfigParser.hs --- a/src/Stack/Options/ConfigParser.hs +++ b/src/Stack/Options/ConfigParser.hs @@ -1,8 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.ConfigParser where import Data.Char -import Data.Either.Combinators -import Data.Monoid.Extra import qualified Data.Set as Set import Options.Applicative import Options.Applicative.Builder.Extra @@ -14,13 +13,14 @@ import Stack.Options.GhcVariantParser import Stack.Options.NixParser import Stack.Options.Utils +import Stack.Prelude import Stack.Types.Config import qualified System.FilePath as FilePath -- | Command-line arguments parser for configuration. configOptsParser :: FilePath -> GlobalOptsContext -> Parser ConfigMonoid configOptsParser currentDir hide0 = - (\stackRoot workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch ghcVariant ghcBuild jobs includes libs overrideGccPath skipGHCCheck skipMsys localBin modifyCodePage allowDifferentUser dumpLogs -> mempty + (\stackRoot workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch ghcVariant ghcBuild jobs includes libs overrideGccPath overrideHpack skipGHCCheck skipMsys localBin modifyCodePage allowDifferentUser dumpLogs -> mempty { configMonoidStackRoot = stackRoot , configMonoidWorkDir = workDir , configMonoidBuildOpts = buildOpts @@ -36,6 +36,7 @@ , configMonoidExtraIncludeDirs = includes , configMonoidExtraLibDirs = libs , configMonoidOverrideGccPath = overrideGccPath + , configMonoidOverrideHpack = overrideHpack , configMonoidSkipMsys = skipMsys , configMonoidLocalBinPath = localBin , configMonoidModifyCodePage = modifyCodePage @@ -101,6 +102,12 @@ ( long "with-gcc" <> metavar "PATH-TO-GCC" <> help "Use gcc found at PATH-TO-GCC" + <> hide + )) + <*> optionalFirst (strOption + ( long "with-hpack" + <> metavar "HPACK" + <> help "Use HPACK executable (overrides bundled Hpack)" <> hide )) <*> firstBoolFlags diff --git a/src/Stack/Options/DockerParser.hs b/src/Stack/Options/DockerParser.hs --- a/src/Stack/Options/DockerParser.hs +++ b/src/Stack/Options/DockerParser.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.DockerParser where import Data.Char import Data.List (intercalate) -import Data.Monoid.Extra import qualified Data.Text as T import Distribution.Version (anyVersion) import Options.Applicative @@ -11,6 +11,7 @@ import Stack.Constants import Stack.Docker import qualified Stack.Docker as Docker +import Stack.Prelude import Stack.Options.Utils import Stack.Types.Version import Stack.Types.Docker @@ -21,7 +22,7 @@ DockerOptsMonoid <$> pure (Any False) <*> firstBoolFlags dockerCmdName - "using a Docker container. Implies 'system-ghc: true'" + "using a Docker container. --docker implies 'system-ghc: true'" hide <*> fmap First ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <> diff --git a/src/Stack/Options/DotParser.hs b/src/Stack/Options/DotParser.hs --- a/src/Stack/Options/DotParser.hs +++ b/src/Stack/Options/DotParser.hs @@ -1,16 +1,17 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Stack.Options.DotParser where import Data.Char (isSpace) import Data.List.Split (splitOn) -import Data.Monoid.Extra import qualified Data.Set as Set import qualified Data.Text as T import Options.Applicative import Options.Applicative.Builder.Extra import Stack.Dot import Stack.Options.BuildParser +import Stack.Prelude -- | Parser for arguments to `stack dot` dotOptsParser :: Bool -> Parser DotOpts diff --git a/src/Stack/Options/ExecParser.hs b/src/Stack/Options/ExecParser.hs --- a/src/Stack/Options/ExecParser.hs +++ b/src/Stack/Options/ExecParser.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.ExecParser where -import Data.Monoid.Extra import Options.Applicative import Options.Applicative.Builder.Extra import Options.Applicative.Args import Stack.Options.Completion +import Stack.Prelude import Stack.Types.Config -- | Parser for exec command @@ -16,7 +17,14 @@ <*> execOptsExtraParser where eoCmdParser = ExecCmd <$> strArgument (metavar "CMD" <> completer projectExeCompleter) - eoArgsParser = many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)")) + eoArgsParser = many (strArgument (metavar txt)) + where + txt = case mcmd of + Nothing -> normalTxt + Just ExecCmd{} -> normalTxt + Just ExecGhc -> "-- ARGS (e.g. stack runghc -- X.hs -o x)" + Just ExecRunGhc -> "-- ARGS (e.g. stack runghc -- X.hs)" + normalTxt = "-- ARGS (e.g. stack exec -- ghc-pkg describe base)" evalOptsParser :: String -- ^ metavar -> Parser EvalOpts @@ -35,6 +43,7 @@ <$> eoEnvSettingsParser <*> eoPackagesParser <*> eoRtsOptionsParser + <*> eoCwdParser where eoEnvSettingsParser :: Parser EnvSettings eoEnvSettingsParser = EnvSettings @@ -48,6 +57,7 @@ "setting the STACK_EXE environment variable to the path for the stack executable" idm <*> pure False + <*> pure True eoPackagesParser :: Parser [String] eoPackagesParser = many (strOption (long "package" <> help "Additional packages that must be installed")) @@ -62,3 +72,11 @@ eoPlainParser = flag' ExecOptsPlain (long "plain" <> help "Use an unmodified environment (only useful with Docker)") + + eoCwdParser :: Parser (Maybe FilePath) + eoCwdParser = optional + (strOption (long "cwd" + <> help "Sets the working directory before executing" + <> metavar "DIR" + <> completer dirCompleter) + ) diff --git a/src/Stack/Options/GhcBuildParser.hs b/src/Stack/Options/GhcBuildParser.hs --- a/src/Stack/Options/GhcBuildParser.hs +++ b/src/Stack/Options/GhcBuildParser.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.GhcBuildParser where -import Data.Monoid.Extra import Options.Applicative import Options.Applicative.Types import Stack.Options.Utils +import Stack.Prelude import Stack.Types.CompilerBuild -- | GHC build parser diff --git a/src/Stack/Options/GhcVariantParser.hs b/src/Stack/Options/GhcVariantParser.hs --- a/src/Stack/Options/GhcVariantParser.hs +++ b/src/Stack/Options/GhcVariantParser.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.GhcVariantParser where -import Data.Monoid.Extra import Options.Applicative import Options.Applicative.Types (readerAsk) +import Stack.Prelude import Stack.Options.Utils import Stack.Types.Config diff --git a/src/Stack/Options/GhciParser.hs b/src/Stack/Options/GhciParser.hs --- a/src/Stack/Options/GhciParser.hs +++ b/src/Stack/Options/GhciParser.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.GhciParser where -import Data.Monoid.Extra import Data.Version (showVersion) import Options.Applicative import Options.Applicative.Args @@ -10,6 +10,7 @@ import Stack.Ghci (GhciOpts (..)) import Stack.Options.BuildParser (flagsParser) import Stack.Options.Completion +import Stack.Prelude -- | Parser for GHCI options ghciOptsParser :: Parser GhciOpts @@ -51,5 +52,6 @@ <*> switch (long "load-local-deps" <> help "Load all local dependencies of your targets") -- TODO: deprecate this? probably useless. <*> switch (long "skip-intermediate-deps" <> help "Skip loading intermediate target dependencies" <> internal) - <*> boolFlags True "package-hiding" "package hiding" idm + <*> optional (boolFlagsNoDefault "package-hiding" "package hiding" idm) <*> switch (long "no-build" <> help "Don't build before launching GHCi" <> internal) + <*> switch (long "only-main" <> help "Only load and import the main module. If no main module, no modules will be loaded.") diff --git a/src/Stack/Options/GlobalParser.hs b/src/Stack/Options/GlobalParser.hs --- a/src/Stack/Options/GlobalParser.hs +++ b/src/Stack/Options/GlobalParser.hs @@ -1,19 +1,20 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards #-} module Stack.Options.GlobalParser where -import Control.Monad.Logger (LogLevel (..)) -import Data.Monoid.Extra import Options.Applicative import Options.Applicative.Builder.Extra import qualified Stack.Docker as Docker import Stack.Init +import Stack.Prelude import Stack.Options.ConfigParser import Stack.Options.LogLevelParser import Stack.Options.ResolverParser import Stack.Options.Utils import Stack.Types.Config import Stack.Types.Docker +import Stack.Types.Runner -- | Parser for global command-line options. globalOptsParser :: FilePath -> GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid @@ -39,6 +40,11 @@ completeWith ["always", "never", "auto"] <> help "Specify when to use color in output; WHEN is 'always', 'never', or 'auto'" <> hide)) <*> + optionalFirst (option auto + (long "terminal-width" <> + metavar "INT" <> + help "Specify the width of the terminal, used for pretty-print messages" <> + hide)) <*> optionalFirst (strOption (long "stack-yaml" <> @@ -63,6 +69,7 @@ , globalCompiler = getFirst globalMonoidCompiler , globalTerminal = fromFirst defaultTerminal globalMonoidTerminal , globalColorWhen = fromFirst ColorAuto globalMonoidColorWhen + , globalTermWidth = getFirst globalMonoidTermWidth , globalStackYaml = maybe SYLDefault SYLOverride $ getFirst globalMonoidStackYaml } initOptsParser :: Parser InitOpts diff --git a/src/Stack/Options/HaddockParser.hs b/src/Stack/Options/HaddockParser.hs --- a/src/Stack/Options/HaddockParser.hs +++ b/src/Stack/Options/HaddockParser.hs @@ -1,10 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.HaddockParser where -import Data.Maybe -import Data.Monoid.Extra import Options.Applicative import Options.Applicative.Args import Stack.Options.Utils +import Stack.Prelude import Stack.Types.Config -- | Parser for haddock arguments. diff --git a/src/Stack/Options/HpcReportParser.hs b/src/Stack/Options/HpcReportParser.hs --- a/src/Stack/Options/HpcReportParser.hs +++ b/src/Stack/Options/HpcReportParser.hs @@ -1,12 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.HpcReportParser where -import Data.Monoid.Extra import qualified Data.Text as T import Options.Applicative import Options.Applicative.Builder.Extra import Options.Applicative.Types (readerAsk) import Stack.Coverage (HpcReportOpts (..)) import Stack.Options.Completion (targetCompleter) +import Stack.Prelude import Stack.Types.Config -- | Parser for @stack hpc report@. diff --git a/src/Stack/Options/LogLevelParser.hs b/src/Stack/Options/LogLevelParser.hs --- a/src/Stack/Options/LogLevelParser.hs +++ b/src/Stack/Options/LogLevelParser.hs @@ -1,12 +1,12 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Stack.Options.LogLevelParser where -import Control.Monad.Logger (LogLevel (..)) -import Data.Monoid.Extra import qualified Data.Text as T import Options.Applicative import Stack.Options.Utils +import Stack.Prelude -- | Parser for a logging level. logLevelOptsParser :: Bool -> Maybe LogLevel -> Parser (Maybe LogLevel) diff --git a/src/Stack/Options/NewParser.hs b/src/Stack/Options/NewParser.hs --- a/src/Stack/Options/NewParser.hs +++ b/src/Stack/Options/NewParser.hs @@ -1,11 +1,12 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.NewParser where import qualified Data.Map.Strict as M -import Data.Monoid.Extra import Options.Applicative import Stack.Init import Stack.New import Stack.Options.GlobalParser +import Stack.Prelude import Stack.Types.PackageName import Stack.Types.TemplateName diff --git a/src/Stack/Options/NixParser.hs b/src/Stack/Options/NixParser.hs --- a/src/Stack/Options/NixParser.hs +++ b/src/Stack/Options/NixParser.hs @@ -1,12 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.NixParser where -import Data.Monoid.Extra import qualified Data.Text as T import Options.Applicative import Options.Applicative.Args import Options.Applicative.Builder.Extra import Stack.Nix import Stack.Options.Utils +import Stack.Prelude import Stack.Types.Nix nixOptsParser :: Bool -> Parser NixOptsMonoid diff --git a/src/Stack/Options/PackageParser.hs b/src/Stack/Options/PackageParser.hs --- a/src/Stack/Options/PackageParser.hs +++ b/src/Stack/Options/PackageParser.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.PackageParser where import qualified Data.Map as Map -import Data.Map.Strict (Map) import Options.Applicative import Options.Applicative.Types (readerAsk) +import Stack.Prelude import Stack.Types.FlagName import Stack.Types.PackageName diff --git a/src/Stack/Options/ResolverParser.hs b/src/Stack/Options/ResolverParser.hs --- a/src/Stack/Options/ResolverParser.hs +++ b/src/Stack/Options/ResolverParser.hs @@ -1,10 +1,12 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} module Stack.Options.ResolverParser where -import Data.Monoid.Extra import qualified Data.Text as T import Options.Applicative import Options.Applicative.Types (readerAsk) import Stack.Options.Utils +import Stack.Prelude import Stack.Types.Compiler import Stack.Types.Resolver @@ -17,7 +19,7 @@ help "Override resolver in project file" <> hideMods hide) -compilerOptsParser :: Bool -> Parser CompilerVersion +compilerOptsParser :: Bool -> Parser (CompilerVersion 'CVWanted) compilerOptsParser hide = option readCompilerVersion (long "compiler" <> @@ -25,7 +27,7 @@ help "Use the specified compiler" <> hideMods hide) -readCompilerVersion :: ReadM CompilerVersion +readCompilerVersion :: ReadM (CompilerVersion 'CVWanted) readCompilerVersion = do s <- readerAsk case parseCompilerVersion (T.pack s) of diff --git a/src/Stack/Options/SDistParser.hs b/src/Stack/Options/SDistParser.hs --- a/src/Stack/Options/SDistParser.hs +++ b/src/Stack/Options/SDistParser.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.SDistParser where -import Data.Monoid import Options.Applicative import Options.Applicative.Builder.Extra +import Stack.Prelude import Stack.SDist import Stack.Options.HpcReportParser (pvpBoundsOption) diff --git a/src/Stack/Options/ScriptParser.hs b/src/Stack/Options/ScriptParser.hs --- a/src/Stack/Options/ScriptParser.hs +++ b/src/Stack/Options/ScriptParser.hs @@ -1,14 +1,17 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.ScriptParser where -import Data.Monoid ((<>)) import Options.Applicative import Options.Applicative.Builder.Extra +import Stack.Options.Completion +import Stack.Prelude data ScriptOpts = ScriptOpts { soPackages :: ![String] , soFile :: !FilePath , soArgs :: ![String] , soCompile :: !ScriptExecute + , soGhcOptions :: ![String] } deriving Show @@ -22,7 +25,7 @@ scriptOptsParser = ScriptOpts <$> many (strOption (long "package" <> help "Additional packages that must be installed")) <*> strArgument (metavar "FILE" <> completer (fileExtCompleter [".hs", ".lhs"])) - <*> many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)")) + <*> many (strArgument (metavar "-- ARGS (e.g. stack script X.hs -- args to program)")) <*> (flag' SECompile ( long "compile" <> help "Compile the script without optimization and run the executable" @@ -32,3 +35,8 @@ <> help "Compile the script with optimization and run the executable" ) <|> pure SEInterpret) + <*> many (strOption + (long "ghc-options" <> + metavar "OPTIONS" <> + completer ghcOptsCompleter <> + help "Additional options passed to GHC")) diff --git a/src/Stack/Options/SolverParser.hs b/src/Stack/Options/SolverParser.hs --- a/src/Stack/Options/SolverParser.hs +++ b/src/Stack/Options/SolverParser.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.SolverParser where import Options.Applicative import Options.Applicative.Builder.Extra +import Stack.Prelude -- | Parser for @solverCmd@ solverOptsParser :: Parser Bool diff --git a/src/Stack/Options/TestParser.hs b/src/Stack/Options/TestParser.hs --- a/src/Stack/Options/TestParser.hs +++ b/src/Stack/Options/TestParser.hs @@ -1,11 +1,11 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.TestParser where -import Data.Maybe -import Data.Monoid.Extra import Options.Applicative import Options.Applicative.Args import Options.Applicative.Builder.Extra import Stack.Options.Utils +import Stack.Prelude import Stack.Types.Config -- | Parser for test arguments. diff --git a/src/Stack/Options/Utils.hs b/src/Stack/Options/Utils.hs --- a/src/Stack/Options/Utils.hs +++ b/src/Stack/Options/Utils.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Options.Utils where -import Data.Monoid.Extra import Options.Applicative +import Stack.Prelude -- | If argument is True, hides the option from usage and help hideMods :: Bool -> Mod f a diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} @@ -15,57 +16,39 @@ -- | Dealing with Cabal. module Stack.Package - (readPackage - ,readPackageBS + (readPackageDir + ,readPackageUnresolvedDir + ,readPackageUnresolvedIndex ,readPackageDescriptionDir ,readDotBuildinfo - ,readPackageUnresolved - ,readPackageUnresolvedBS ,resolvePackage ,packageFromPackageDescription - ,findOrGenerateCabalFile - ,hpack ,Package(..) + ,PackageDescriptionPair(..) ,GetPackageFiles(..) ,GetPackageOpts(..) ,PackageConfig(..) ,buildLogPath ,PackageException (..) ,resolvePackageDescription - ,packageToolDependencies + ,packageDescTools ,packageDependencies ,autogenDir - ,checkCabalFileName - ,printCabalFileWarning - ,cabalFilePackageId) + ,cabalFilePackageId + ,gpdPackageIdentifier + ,gpdPackageName + ,gpdVersion) where -import Prelude () -import Prelude.Compat - -import Control.Arrow ((&&&)) -import Control.Exception hiding (try,catch) -import Control.Monad (liftM, liftM2, (<=<), when, forM, forM_) -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Reader (MonadReader,runReaderT,ask,asks) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 -import Data.List.Compat +import Data.List (isSuffixOf, partition, isPrefixOf) import Data.List.Extra (nubOrd) -import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Maybe.Extra -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, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) -import Data.Version (showVersion) import Distribution.Compiler import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as Cabal @@ -79,18 +62,27 @@ import Distribution.Simple.Utils import Distribution.System (OS (..), Arch, Platform (..)) import qualified Distribution.Text as D +import qualified Distribution.Types.CondTree as Cabal +import qualified Distribution.Types.ExeDependency as Cabal +import Distribution.Types.ForeignLib +import qualified Distribution.Types.LegacyExeDependency as Cabal +import qualified Distribution.Types.UnqualComponentName as Cabal import qualified Distribution.Verbosity as D +import Distribution.Version (showVersion) +import Lens.Micro (lens) import qualified Hpack import qualified Hpack.Config as Hpack import Path as FL import Path.Extra import Path.Find import Path.IO hiding (findFiles) -import Safe (headDef, tailSafe) import Stack.Build.Installed import Stack.Constants +import Stack.Constants.Config +import Stack.Prelude import Stack.PrettyPrint import Stack.Types.Build +import Stack.Types.BuildPlan (ExeName (..)) import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName @@ -98,29 +90,40 @@ import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName +import Stack.Types.Runner import Stack.Types.Version import qualified System.Directory as D import System.FilePath (splitExtensions, replaceExtension) import qualified System.FilePath as FilePath import System.IO.Error +import System.Process.Run (runCmd, Cmd(..)) --- | Read the raw, unresolved package information. -readPackageUnresolved :: (MonadIO m, MonadThrow m) - => Path Abs File - -> m ([PWarning],GenericPackageDescription) -readPackageUnresolved cabalfp = - liftIO (BS.readFile (FL.toFilePath cabalfp)) - >>= readPackageUnresolvedBS (Left cabalfp) +data Ctx = Ctx { ctxFile :: !(Path Abs File) + , ctxDir :: !(Path Abs Dir) + , ctxEnvConfig :: !EnvConfig + } --- | Read the raw, unresolved package information from a ByteString. -readPackageUnresolvedBS :: (MonadThrow m) - => Either (Path Abs File) PackageIdentifier - -> BS.ByteString - -> m ([PWarning],GenericPackageDescription) -readPackageUnresolvedBS source bs = - case parsePackageDescription chars of - ParseFailed per -> - throwM (PackageInvalidCabalFile source per) +instance HasPlatform Ctx +instance HasGHCVariant Ctx +instance HasLogFunc Ctx where + logFuncL = configL.logFuncL +instance HasRunner Ctx where + runnerL = configL.runnerL +instance HasConfig Ctx +instance HasBuildConfig Ctx +instance HasEnvConfig Ctx where + envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) + +-- | A helper function that performs the basic character encoding +-- necessary. +rawParseGPD + :: MonadThrow m + => Either PackageIdentifierRevision (Path Abs File) + -> BS.ByteString + -> m ([PWarning], GenericPackageDescription) +rawParseGPD key bs = + case parseGenericPackageDescription chars of + ParseFailed e -> throwM $ PackageInvalidCabalFile key e ParseOk warnings gpkg -> return (warnings,gpkg) where chars = T.unpack (dropBOM (decodeUtf8With lenientDecode bs)) @@ -128,34 +131,102 @@ -- https://github.com/haskell/hackage-server/issues/351 dropBOM t = fromMaybe t $ T.stripPrefix "\xFEFF" t --- | Reads and exposes the package information -readPackage :: (MonadLogger m, MonadIO m, MonadCatch m) - => PackageConfig - -> Path Abs File - -> m ([PWarning],Package) -readPackage packageConfig cabalfp = - do (warnings,gpkg) <- readPackageUnresolved cabalfp - return (warnings,resolvePackage packageConfig gpkg) +-- | Read the raw, unresolved package information from a file. +readPackageUnresolvedDir + :: forall env. HasConfig env + => Path Abs Dir -- ^ directory holding the cabal file + -> Bool -- ^ print warnings? + -> RIO env (GenericPackageDescription, Path Abs File) +readPackageUnresolvedDir dir printWarnings = do + ref <- view $ runnerL.to runnerParsedCabalFiles + (_, m) <- readIORef ref + case M.lookup dir m of + Just x -> return x + Nothing -> do + cabalfp <- findOrGenerateCabalFile dir + bs <- liftIO $ BS.readFile $ toFilePath cabalfp + (warnings, gpd) <- rawParseGPD (Right cabalfp) bs + when printWarnings + $ mapM_ (prettyWarnL . toPretty (toFilePath cabalfp)) warnings + checkCabalFileName (gpdPackageName gpd) cabalfp + let ret = (gpd, cabalfp) + atomicModifyIORef' ref $ \(m1, m2) -> + ((m1, M.insert dir ret m2), ret) + where + toPretty :: String -> PWarning -> [Doc AnsiAnn] + toPretty src (PWarning x) = + [ flow "Cabal file warning in" + , fromString src <> ":" + , flow x + ] + toPretty src (UTFWarning ln msg) = + [ flow "Cabal file warning in" + , fromString src <> ":" <> fromString (show ln) <> ":" + , flow msg + ] --- | Reads and exposes the package information, from a ByteString -readPackageBS :: (MonadThrow m) - => PackageConfig - -> PackageIdentifier - -> BS.ByteString - -> m ([PWarning],Package) -readPackageBS packageConfig ident bs = - do (warnings,gpkg) <- readPackageUnresolvedBS (Right ident) bs - return (warnings,resolvePackage packageConfig gpkg) + -- | Check if the given name in the @Package@ matches the name of the .cabal file + checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m () + checkCabalFileName name cabalfp = do + -- Previously, we just use parsePackageNameFromFilePath. However, that can + -- lead to confusing error messages. See: + -- https://github.com/commercialhaskell/stack/issues/895 + let expected = packageNameString name ++ ".cabal" + when (expected /= toFilePath (filename cabalfp)) + $ throwM $ MismatchedCabalName cabalfp name +gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier +gpdPackageIdentifier = fromCabalPackageIdentifier . D.package . D.packageDescription + +gpdPackageName :: GenericPackageDescription -> PackageName +gpdPackageName = packageIdentifierName . gpdPackageIdentifier + +gpdVersion :: GenericPackageDescription -> Version +gpdVersion = packageIdentifierVersion . gpdPackageIdentifier + +-- | Read the 'GenericPackageDescription' from the given +-- 'PackageIdentifierRevision'. +readPackageUnresolvedIndex + :: forall env. HasRunner env + => (PackageIdentifierRevision -> IO ByteString) -- ^ load the raw bytes + -> PackageIdentifierRevision + -> RIO env GenericPackageDescription +readPackageUnresolvedIndex loadFromIndex pir@(PackageIdentifierRevision pi' _) = do + ref <- view $ runnerL.to runnerParsedCabalFiles + (m, _) <- readIORef ref + case M.lookup pir m of + Just gpd -> return gpd + Nothing -> do + bs <- liftIO $ loadFromIndex pir + (_warnings, gpd) <- rawParseGPD (Left pir) bs + let foundPI = + fromCabalPackageIdentifier + $ D.package + $ D.packageDescription gpd + unless (pi' == foundPI) $ throwM $ MismatchedCabalIdentifier pir foundPI + atomicModifyIORef' ref $ \(m1, m2) -> + ((M.insert pir gpd m1, m2), gpd) + +-- | Reads and exposes the package information +readPackageDir + :: forall env. HasConfig env + => PackageConfig + -> Path Abs Dir + -> Bool -- ^ print warnings from cabal file parsing? + -> RIO env (Package, Path Abs File) +readPackageDir packageConfig dir printWarnings = + first (resolvePackage packageConfig) <$> readPackageUnresolvedDir dir printWarnings + -- | Get 'GenericPackageDescription' and 'PackageDescription' reading info -- from given directory. -readPackageDescriptionDir :: (MonadLogger m, MonadIO m, MonadCatch m) +readPackageDescriptionDir + :: forall env. HasConfig env => PackageConfig -> Path Abs Dir - -> m (GenericPackageDescription, PackageDescription) -readPackageDescriptionDir config pkgDir = do - cabalfp <- findOrGenerateCabalFile pkgDir - gdesc <- liftM snd (readPackageUnresolved cabalfp) + -> Bool -- ^ print warnings? + -> RIO env (GenericPackageDescription, PackageDescriptionPair) +readPackageDescriptionDir config pkgDir printWarnings = do + (gdesc, _) <- readPackageUnresolvedDir pkgDir printWarnings return (gdesc, resolvePackageDescription config gdesc) -- | Read @.buildinfo@ ancillary files produced by some Setup.hs hooks. @@ -169,34 +240,6 @@ readDotBuildinfo buildinfofp = liftIO $ readHookedBuildInfo D.silent (toFilePath buildinfofp) --- | Print cabal file warnings. -printCabalFileWarning - :: (MonadLogger m) - => Path Abs File -> PWarning -> m () -printCabalFileWarning cabalfp = - \case - (PWarning x) -> - $logWarn - ("Cabal file warning in " <> T.pack (toFilePath cabalfp) <> - ": " <> - T.pack x) - (UTFWarning ln msg) -> - $logWarn - ("Cabal file warning in " <> T.pack (toFilePath cabalfp) <> ":" <> - T.pack (show ln) <> - ": " <> - T.pack msg) - --- | Check if the given name in the @Package@ matches the name of the .cabal file -checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m () -checkCabalFileName name cabalfp = do - -- Previously, we just use parsePackageNameFromFilePath. However, that can - -- lead to confusing error messages. See: - -- https://github.com/commercialhaskell/stack/issues/895 - let expected = packageNameString name ++ ".cabal" - when (expected /= toFilePath (filename cabalfp)) - $ throwM $ MismatchedCabalName cabalfp name - -- | Resolve a parsed cabal file into a 'Package', which contains all of -- the info needed for stack to build the 'Package' given the current -- configuration. @@ -211,9 +254,9 @@ packageFromPackageDescription :: PackageConfig -> [D.Flag] - -> PackageDescription + -> PackageDescriptionPair -> Package -packageFromPackageDescription packageConfig pkgFlags pkg = +packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkgNoMod pkg) = Package { packageName = name , packageVersion = fromCabalVersion (pkgVersion pkgId) @@ -226,15 +269,31 @@ , packageDefaultFlags = M.fromList [(fromCabalFlagName (flagName flag), flagDefault flag) | flag <- pkgFlags] , packageAllDeps = S.fromList (M.keys deps) - , packageHasLibrary = maybe False (buildable . libBuildInfo) (library pkg) + , packageLibraries = + let mlib = do + lib <- library pkg + guard $ buildable $ libBuildInfo lib + Just lib + in + case mlib of + Nothing + | null extraLibNames -> NoLibraries + | otherwise -> error "Package has buildable sublibraries but no buildable libraries, I'm giving up" + Just _ -> HasLibraries foreignLibNames , packageTests = M.fromList - [(T.pack (testName t), testInterface t) | t <- testSuites pkg - , buildable (testBuildInfo t)] + [(T.pack (Cabal.unUnqualComponentName $ testName t), testInterface t) + | t <- testSuites pkgNoMod + , buildable (testBuildInfo t) + ] , packageBenchmarks = S.fromList - [T.pack (benchmarkName biBuildInfo) | biBuildInfo <- benchmarks pkg - , buildable (benchmarkBuildInfo biBuildInfo)] + [T.pack (Cabal.unUnqualComponentName $ benchmarkName b) + | b <- benchmarks pkgNoMod + , buildable (benchmarkBuildInfo b) + ] + -- Same comment about buildable applies here too. , packageExes = S.fromList - [T.pack (exeName biBuildInfo) | biBuildInfo <- executables pkg + [T.pack (Cabal.unUnqualComponentName $ exeName biBuildInfo) + | biBuildInfo <- executables pkg , buildable (buildInfo biBuildInfo)] -- This is an action used to collect info needed for "stack ghci". -- This info isn't usually needed, so computation of it is deferred. @@ -252,17 +311,33 @@ , packageSetupDeps = msetupDeps } where + extraLibNames = S.union subLibNames foreignLibNames + + subLibNames + = S.fromList + $ map (T.pack . Cabal.unUnqualComponentName) + $ mapMaybe libName -- this is a design bug in the Cabal API: this should statically be known to exist + $ filter (buildable . libBuildInfo) + $ subLibraries pkg + + foreignLibNames + = S.fromList + $ map (T.pack . Cabal.unUnqualComponentName . foreignLibName) + $ filter (buildable . foreignLibBuildInfo) + $ foreignLibs pkg + -- Gets all of the modules, files, build files, and data files that -- constitute the package. This is primarily used for dirtiness -- checking during build, as well as use by "stack ghci" pkgFiles = GetPackageFiles $ - \cabalfp -> $debugBracket ("getPackageFiles" <+> display cabalfp) $ do + \cabalfp -> debugBracket ("getPackageFiles" <+> display cabalfp) $ do let pkgDir = parent cabalfp distDir <- distDirFromDir pkgDir + env <- view envConfigL (componentModules,componentFiles,dataFiles',warnings) <- runReaderT (packageDescModulesAndFiles pkg) - (cabalfp, buildDir distDir) + (Ctx cabalfp (buildDir distDir) env) setupFiles <- if buildType pkg `elem` [Nothing, Just Custom] then do @@ -280,7 +355,7 @@ return (componentModules, componentFiles, buildFiles <> dataFiles', warnings) pkgId = package pkg name = fromCabalPackageName (pkgName pkgId) - deps = M.filterWithKey (const . (/= name)) (M.union + deps = M.filterWithKey (const . not . isMe) (M.union (packageDependencies pkg) -- We include all custom-setup deps - if present - in the -- package deps themselves. Stack always works with the @@ -292,6 +367,10 @@ (M.fromList . map (depName &&& depRange) . setupDepends) (setupBuildInfo pkg) + -- Is the package dependency mentioned here me: either the package + -- name itself, or the name of one of the sub libraries + isMe name' = name' == name || packageNameText name' `S.member` extraLibNames + -- | Generate GHC options for the package's components, and a list of -- options which apply generally to the package, not one specific -- component. @@ -341,19 +420,19 @@ , fmap (\exe -> generate - (CExe (T.pack (exeName exe))) + (CExe (T.pack (Cabal.unUnqualComponentName (exeName exe)))) (buildInfo exe)) (executables pkg) , fmap (\bench -> generate - (CBench (T.pack (benchmarkName bench))) + (CBench (T.pack (Cabal.unUnqualComponentName (benchmarkName bench)))) (benchmarkBuildInfo bench)) (benchmarks pkg) , fmap (\test -> generate - (CTest (T.pack (testName test))) + (CTest (T.pack (Cabal.unUnqualComponentName (testName test)))) (testBuildInfo test)) (testSuites pkg)])) where @@ -404,7 +483,7 @@ deps = concat [ case M.lookup name biInstalledMap of - Just (_, Stack.Types.Package.Library _ident ipid) -> ["-package-id=" <> ghcPkgIdString ipid] + Just (_, Stack.Types.Package.Library _ident ipid _) -> ["-package-id=" <> ghcPkgIdString ipid] _ -> ["-package=" <> packageNameString name <> maybe "" -- This empty case applies to e.g. base. ((("-" <>) . versionString) . piiVersion) @@ -489,7 +568,7 @@ -> Path Abs File -- ^ The path to the .c file. -> m (Path Abs File) -- ^ The path to the .o file for the component. makeObjectFilePathFromC cabalDir namedComponent distDir cFilePath = do - relCFilePath <- stripDir cabalDir cFilePath + relCFilePath <- stripProperPrefix cabalDir cFilePath relOFilePath <- parseRelFile (replaceExtension (toFilePath relCFilePath) "o") addComponentPrefix <- fileGenDirFromComponentName namedComponent @@ -530,44 +609,38 @@ concatMap targetBuildDepends (allBuildInfo' pkg) ++ maybe [] setupDepends (setupBuildInfo pkg) --- | Get all build tool dependencies of the package (buildable targets only). -packageToolDependencies :: PackageDescription -> Map Text VersionRange -packageToolDependencies = - M.fromList . - concatMap (fmap (packageNameText . depName &&& depRange) . - buildTools) . - allBuildInfo' - -- | Get all dependencies of the package (buildable targets only). -packageDescTools :: PackageDescription -> [Dependency] -packageDescTools = concatMap buildTools . allBuildInfo' +-- +-- This uses both the new 'buildToolDepends' and old 'buildTools' +-- information. +packageDescTools :: PackageDescription -> Map ExeName VersionRange +packageDescTools = + M.fromList . concatMap tools . allBuildInfo' + where + tools bi = map go1 (buildTools bi) ++ map go2 (buildToolDepends bi) --- | This is a copy-paste from Cabal's @allBuildInfo@ function, but with the --- @buildable@ test removed. The implementation is broken. --- See: https://github.com/haskell/cabal/issues/1725 + go1 :: Cabal.LegacyExeDependency -> (ExeName, VersionRange) + go1 (Cabal.LegacyExeDependency name range) = (ExeName $ T.pack name, range) + + go2 :: Cabal.ExeDependency -> (ExeName, VersionRange) + go2 (Cabal.ExeDependency _pkg name range) = (ExeName $ T.pack $ Cabal.unUnqualComponentName name, range) + +-- | Variant of 'allBuildInfo' from Cabal that includes foreign +-- libraries; see allBuildInfo' :: PackageDescription -> [BuildInfo] -allBuildInfo' pkg_descr = [ bi | Just lib <- [library pkg_descr] - , let bi = libBuildInfo lib - , True || buildable bi ] - ++ [ bi | exe <- executables pkg_descr - , let bi = buildInfo exe - , True || buildable bi ] - ++ [ bi | tst <- testSuites pkg_descr - , let bi = testBuildInfo tst - , True || buildable bi - , testEnabled tst ] - ++ [ bi | tst <- benchmarks pkg_descr - , let bi = benchmarkBuildInfo tst - , True || buildable bi - , benchmarkEnabled tst ] +allBuildInfo' pkg = allBuildInfo pkg ++ + [ bi | flib <- foreignLibs pkg + , let bi = foreignLibBuildInfo flib + , buildable bi + ] -- | Get all files referenced by the package. packageDescModulesAndFiles - :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadCatch m) + :: (MonadLogger m, MonadUnliftIO m, MonadReader Ctx m, MonadThrow m) => PackageDescription -> m (Map NamedComponent (Set ModuleName), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning]) packageDescModulesAndFiles pkg = do - (libraryMods,libDotCabalFiles,libWarnings) <- + (libraryMods,libDotCabalFiles,libWarnings) <- -- FIXME add in sub libraries maybe (return (M.empty, M.empty, [])) (asModuleAndFileMap libComponent libraryFiles) @@ -599,16 +672,16 @@ return (modules, files, dfiles, warnings) where libComponent = const CLib - exeComponent = CExe . T.pack . exeName - testComponent = CTest . T.pack . testName - benchComponent = CBench . T.pack . benchmarkName + exeComponent = CExe . T.pack . Cabal.unUnqualComponentName . exeName + testComponent = CTest . T.pack . Cabal.unUnqualComponentName . testName + benchComponent = CBench . T.pack . Cabal.unUnqualComponentName . benchmarkName asModuleAndFileMap label f lib = do (a,b,c) <- f lib return (M.singleton (label lib) a, M.singleton (label lib) b, c) foldTuples = foldl' (<>) (M.empty, M.empty, []) -- | Resolve globbing of files (e.g. data files) to absolute paths. -resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadReader (Path Abs File, Path Abs Dir) m,MonadCatch m) +resolveGlobFiles :: (MonadLogger m,MonadUnliftIO m,MonadReader Ctx m) => [String] -> m (Set (Path Abs File)) resolveGlobFiles = liftM (S.fromList . catMaybes . concat) . @@ -619,7 +692,7 @@ then explode name else liftM return (resolveFileOrWarn name) explode name = do - dir <- asks (parent . fst) + dir <- asks (parent . ctxFile) names <- matchDirFileGlob' (FL.toFilePath dir) @@ -631,11 +704,14 @@ (\(e :: IOException) -> if isUserError e then do - $logWarn - ("Wildcard does not match any files: " <> T.pack glob <> "\n" <> - "in directory: " <> T.pack dir) + prettyWarnL + [ flow "Wildcard does not match any files:" + , styleFile $ fromString glob + , line <> flow "in directory:" + , styleDir $ fromString dir + ] return [] - else throwM e) + else throwIO e) -- | This is a copy/paste of the Cabal library function, but with -- @@ -652,9 +728,9 @@ -- ["test/package-dump/ghc-7.8.txt","test/package-dump/ghc-7.10.txt"] -- @ -- -matchDirFileGlob_ :: (MonadLogger m, MonadIO m) => String -> String -> m [String] +matchDirFileGlob_ :: (MonadLogger m, MonadIO m, HasRunner env, MonadReader env m) => String -> String -> m [String] matchDirFileGlob_ dir filepath = case parseFileGlob filepath of - Nothing -> liftIO $ die $ + Nothing -> liftIO $ throwString $ "invalid file glob '" ++ filepath ++ "'. Wildcards '*' are only allowed in place of the file" ++ " name, not in the directory name or file extension." @@ -672,19 +748,23 @@ , not (null name) && isSuffixOf ext ext' ] when (null matches) $ - $logWarn $ "WARNING: filepath wildcard '" <> T.pack filepath <> "' does not match any files." + prettyWarnL + [ flow "filepath wildcard" + , "'" <> styleFile (fromString filepath) <> "'" + , flow "does not match any files." + ] return matches -- | Get all files referenced by the benchmark. benchmarkFiles - :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m) => Benchmark -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) benchmarkFiles bench = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) - dir <- asks (parent . fst) + dir <- asks (parent . ctxFile) (modules,files,warnings) <- resolveFilesAndDeps - (Just $ benchmarkName bench) + (Just $ Cabal.unUnqualComponentName $ benchmarkName bench) (dirs ++ [dir]) (bnames <> exposed) haskellModuleExts @@ -700,15 +780,15 @@ -- | Get all files referenced by the test. testFiles - :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m) => TestSuite -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) testFiles test = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) - dir <- asks (parent . fst) + dir <- asks (parent . ctxFile) (modules,files,warnings) <- resolveFilesAndDeps - (Just $ testName test) + (Just $ Cabal.unUnqualComponentName $ testName test) (dirs ++ [dir]) (bnames <> exposed) haskellModuleExts @@ -725,15 +805,15 @@ -- | Get all files referenced by the executable. executableFiles - :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m) => Executable -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) executableFiles exe = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) - dir <- asks (parent . fst) + dir <- asks (parent . ctxFile) (modules,files,warnings) <- resolveFilesAndDeps - (Just $ exeName exe) + (Just $ Cabal.unUnqualComponentName $ exeName exe) (dirs ++ [dir]) (map DotCabalModule (otherModules build) ++ [DotCabalMain (modulePath exe)]) @@ -745,11 +825,11 @@ -- | Get all files referenced by the library. libraryFiles - :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m) => Library -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) libraryFiles lib = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) - dir <- asks (parent . fst) + dir <- asks (parent . ctxFile) (modules,files,warnings) <- resolveFilesAndDeps Nothing @@ -765,7 +845,7 @@ build = libBuildInfo lib -- | Get all C sources and extra source files in a build. -buildOtherSources :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader (Path Abs File, Path Abs Dir) m) +buildOtherSources :: (MonadLogger m,MonadIO m,MonadReader Ctx m) => BuildInfo -> m (Set DotCabalPath) buildOtherSources build = do csources <- liftM @@ -780,24 +860,59 @@ targetJsSources :: BuildInfo -> [FilePath] targetJsSources = jsSources +-- | A pair of package descriptions: one which modified the buildable +-- values of test suites and benchmarks depending on whether they are +-- enabled, and one which does not. +-- +-- Fields are intentionally lazy, we may only need one or the other +-- value. +-- +-- MSS 2017-08-29: The very presence of this data type is terribly +-- ugly, it represents the fact that the Cabal 2.0 upgrade did _not_ +-- go well. Specifically, we used to have a field to indicate whether +-- a component was enabled in addition to buildable, but that's gone +-- now, and this is an ugly proxy. We should at some point clean up +-- the mess of Package, LocalPackage, etc, and probably pull in the +-- definition of PackageDescription from Cabal with our additionally +-- needed metadata. But this is a good enough hack for the +-- moment. Odds are, you're reading this in the year 2024 and thinking +-- "wtf?" +data PackageDescriptionPair = PackageDescriptionPair + { pdpOrigBuildable :: PackageDescription + , pdpModifiedBuildable :: PackageDescription + } + -- | Evaluates the conditions of a 'GenericPackageDescription', yielding -- a resolved 'PackageDescription'. resolvePackageDescription :: PackageConfig -> GenericPackageDescription - -> PackageDescription -resolvePackageDescription packageConfig (GenericPackageDescription desc defaultFlags mlib exes tests benches) = - desc {library = - fmap (resolveConditions rc updateLibDeps) mlib - ,executables = - map (\(n, v) -> (resolveConditions rc updateExeDeps v){exeName=n}) - exes - ,testSuites = - map (\(n,v) -> (resolveConditions rc updateTestDeps v){testName=n}) - tests - ,benchmarks = - map (\(n,v) -> (resolveConditions rc updateBenchmarkDeps v){benchmarkName=n}) - benches} - where flags = + -> PackageDescriptionPair +resolvePackageDescription packageConfig (GenericPackageDescription desc defaultFlags mlib subLibs foreignLibs' exes tests benches) = + PackageDescriptionPair + { pdpOrigBuildable = go False + , pdpModifiedBuildable = go True + } + where + go modBuildable = + desc {library = + fmap (resolveConditions rc updateLibDeps) mlib + ,subLibraries = + map (\(n, v) -> (resolveConditions rc updateLibDeps v){libName=Just n}) + subLibs + ,foreignLibs = + map (\(n, v) -> (resolveConditions rc updateForeignLibDeps v){foreignLibName=n}) + foreignLibs' + ,executables = + map (\(n, v) -> (resolveConditions rc updateExeDeps v){exeName=n}) + exes + ,testSuites = + map (\(n,v) -> (resolveConditions rc (updateTestDeps modBuildable) v){testName=n}) + tests + ,benchmarks = + map (\(n,v) -> (resolveConditions rc (updateBenchmarkDeps modBuildable) v){benchmarkName=n}) + benches} + + flags = M.union (packageConfigFlags packageConfig) (flagMap defaultFlags) @@ -809,18 +924,39 @@ updateLibDeps lib deps = lib {libBuildInfo = (libBuildInfo lib) {targetBuildDepends = deps}} + updateForeignLibDeps lib deps = + lib {foreignLibBuildInfo = + (foreignLibBuildInfo lib) {targetBuildDepends = deps}} updateExeDeps exe deps = exe {buildInfo = (buildInfo exe) {targetBuildDepends = deps}} - updateTestDeps test deps = - test {testBuildInfo = - (testBuildInfo test) {targetBuildDepends = deps} - ,testEnabled = packageConfigEnableTests packageConfig} - updateBenchmarkDeps benchmark deps = - benchmark {benchmarkBuildInfo = - (benchmarkBuildInfo benchmark) {targetBuildDepends = deps} - ,benchmarkEnabled = packageConfigEnableBenchmarks packageConfig} + -- Note that, prior to moving to Cabal 2.0, we would set + -- testEnabled/benchmarkEnabled here. These fields no longer + -- exist, so we modify buildable instead here. The only + -- wrinkle in the Cabal 2.0 story is + -- https://github.com/haskell/cabal/issues/1725, where older + -- versions of Cabal (which may be used for actually building + -- code) don't properly exclude build-depends for + -- non-buildable components. Testing indicates that everything + -- is working fine, and that this comment can be completely + -- ignored. I'm leaving the comment anyway in case something + -- breaks and you, poor reader, are investigating. + updateTestDeps modBuildable test deps = + let bi = testBuildInfo test + bi' = bi + { targetBuildDepends = deps + , buildable = buildable bi && (if modBuildable then packageConfigEnableTests packageConfig else True) + } + in test { testBuildInfo = bi' } + updateBenchmarkDeps modBuildable benchmark deps = + let bi = benchmarkBuildInfo benchmark + bi' = bi + { targetBuildDepends = deps + , buildable = buildable bi && (if modBuildable then packageConfigEnableBenchmarks packageConfig else True) + } + in benchmark { benchmarkBuildInfo = bi' } + -- | Make a map from a list of flag specifications. -- -- What is @flagManual@ for? @@ -831,13 +967,13 @@ data ResolveConditions = ResolveConditions { rcFlags :: Map FlagName Bool - , rcCompilerVersion :: CompilerVersion + , rcCompilerVersion :: CompilerVersion 'CVActual , rcOS :: OS , rcArch :: Arch } -- | Generic a @ResolveConditions@ using sensible defaults. -mkResolveConditions :: CompilerVersion -- ^ Compiler version +mkResolveConditions :: CompilerVersion 'CVActual -- ^ Compiler version -> Platform -- ^ installation target platform -> Map FlagName Bool -- ^ enabled flags -> ResolveConditions @@ -857,7 +993,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) = + where apply (Cabal.CondBranch cond node mcs) = if condSatisfied cond then resolveConditions rc addDeps node else maybe mempty (resolveConditions rc addDeps) mcs @@ -901,7 +1037,7 @@ -- extensions, plus find any of their module and TemplateHaskell -- dependencies. resolveFilesAndDeps - :: (MonadIO m, MonadLogger m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadIO m, MonadLogger m, MonadReader Ctx m, MonadThrow m) => Maybe String -- ^ Package component name -> [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. @@ -955,7 +1091,7 @@ -- TODO: bring this back - see -- https://github.com/commercialhaskell/stack/issues/2649 {- - cabalfp <- asks fst + cabalfp <- asks ctxFile return $ if null missingModules then [] @@ -968,7 +1104,7 @@ -- | Get the dependencies of a Haskell module file. getDependencies - :: (MonadReader (Path Abs File, Path Abs Dir) m, MonadIO m, MonadCatch m, MonadLogger m) + :: (MonadReader Ctx m, MonadIO m, MonadLogger m) => Maybe String -> DotCabalPath -> m (Set ModuleName, [Path Abs File]) getDependencies component dotCabalPath = case dotCabalPath of @@ -979,8 +1115,8 @@ where readResolvedHi resolvedFile = do dumpHIDir <- getDumpHIDir - dir <- asks (parent . fst) - case stripDir dir resolvedFile of + dir <- asks (parent . ctxFile) + case stripProperPrefix dir resolvedFile of Nothing -> return (S.empty, []) Just fileRel -> do let dumpHIPath = @@ -992,15 +1128,15 @@ then parseDumpHI dumpHIPath else return (S.empty, []) getDumpHIDir = do - bld <- asks snd + bld <- asks ctxDir return $ maybe bld (bld ) (getBuildComponentDir component) -- | Parse a .dump-hi file into a set of modules and files. parseDumpHI - :: (MonadReader (Path Abs File, void) m, MonadIO m, MonadCatch m, MonadLogger m) + :: (MonadReader Ctx m, MonadIO m, MonadLogger m) => FilePath -> m (Set ModuleName, [Path Abs File]) parseDumpHI dumpHIPath = do - dir <- asks (parent . fst) + dir <- asks (parent . ctxFile) dumpHI <- liftIO $ fmap C8.lines (C8.readFile dumpHIPath) let startModuleDeps = dropWhile (not . ("module dependencies:" `C8.isPrefixOf`)) dumpHI @@ -1009,8 +1145,8 @@ mapMaybe (D.simpleParse . T.unpack . decodeUtf8) $ C8.words $ C8.concat $ - C8.dropWhile (/= ' ') (headDef "" startModuleDeps) : - takeWhile (" " `C8.isPrefixOf`) (tailSafe startModuleDeps) + C8.dropWhile (/= ' ') (fromMaybe "" $ listToMaybe startModuleDeps) : + takeWhile (" " `C8.isPrefixOf`) (drop 1 startModuleDeps) thDeps = -- The dependent file path is surrounded by quotes but is not escaped. -- It can be an absolute or relative path. @@ -1020,10 +1156,14 @@ T.dropWhileEnd (== '\r') . decodeUtf8 . C8.dropWhile (/= '"')) $ filter ("addDependentFile \"" `C8.isPrefixOf`) dumpHI thDepsResolved <- liftM catMaybes $ forM thDeps $ \x -> do - mresolved <- forgivingAbsence (resolveFile dir x) >>= rejectMissingFile + mresolved <- liftIO (forgivingAbsence (resolveFile dir x)) >>= rejectMissingFile when (isNothing mresolved) $ - $logWarn $ "Warning: addDependentFile path (Template Haskell) listed in " <> T.pack dumpHIPath <> - " does not exist: " <> T.pack x + prettyWarnL + [ flow "addDependentFile path (Template Haskell) listed in" + , styleFile $ fromString dumpHIPath + , flow "does not exist:" + , styleFile $ fromString x + ] return mresolved return (moduleDeps, thDepsResolved) @@ -1031,7 +1171,7 @@ -- looking for unique instances of base names applied with the given -- extensions. resolveFiles - :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader Ctx m) => [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. -> [Text] -- ^ Extensions. @@ -1042,13 +1182,13 @@ -- | Find a candidate for the given module-or-filename from the list -- of directories and given extensions. findCandidate - :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader Ctx m) => [Path Abs Dir] -> [Text] -> DotCabalDescriptor -> m (Maybe DotCabalPath) findCandidate dirs exts name = do - pkg <- asks fst >>= parsePackageNameFromFilePath + pkg <- asks ctxFile >>= parsePackageNameFromFilePath candidates <- liftIO makeNameCandidates case candidates of [candidate] -> return (Just (cons candidate)) @@ -1097,20 +1237,24 @@ -- | Warn the user that multiple candidates are available for an -- entry, but that we picked one anyway and continued. warnMultiple - :: MonadLogger m + :: (MonadLogger m, HasRunner env, MonadReader env m) => DotCabalDescriptor -> Path b t -> [Path b t] -> m () warnMultiple name candidate rest = - $logWarn - ("There were multiple candidates for the Cabal entry \"" <> - showName name <> - "\" (" <> - T.intercalate "," (map (T.pack . toFilePath) rest) <> - "), picking " <> - T.pack (toFilePath candidate)) - where showName (DotCabalModule name') = T.pack (D.display name') - showName (DotCabalMain fp) = T.pack fp - showName (DotCabalFile fp) = T.pack fp - showName (DotCabalCFile fp) = T.pack fp + -- TODO: figure out how to style 'name' and the dispOne stuff + prettyWarnL + [ flow "There were multiple candidates for the Cabal entry \"" + , fromString . showName $ name + , line <> bulletedList (map dispOne rest) + , line <> flow "picking:" + , dispOne candidate + ] + where showName (DotCabalModule name') = D.display name' + showName (DotCabalMain fp) = fp + showName (DotCabalFile fp) = fp + showName (DotCabalCFile fp) = fp + dispOne = fromString . toFilePath + -- TODO: figure out why dispOne can't be just `display` + -- (remove the .hlint.yaml exception if it can be) -- | Log that we couldn't find a candidate, but there are -- possibilities for custom preprocessor extensions. @@ -1118,21 +1262,20 @@ -- For example: .erb for a Ruby file might exist in one of the -- directories. logPossibilities - :: (MonadIO m, MonadThrow m, MonadLogger m) + :: (MonadIO m, MonadThrow m, MonadLogger m, HasRunner env, + MonadReader env m) => [Path Abs Dir] -> ModuleName -> m () logPossibilities dirs mn = do possibilities <- liftM concat (makePossibilities mn) - case possibilities of - [] -> return () - _ -> - $logWarn - ("Unable to find a known candidate for the Cabal entry \"" <> - T.pack (D.display mn) <> - "\", but did find: " <> - T.intercalate ", " (map (T.pack . toFilePath) possibilities) <> - ". If you are using a custom preprocessor for this module " <> - "with its own file extension, consider adding the file(s) " <> - "to your .cabal under extra-source-files.") + unless (null possibilities) $ prettyWarnL + [ flow "Unable to find a known candidate for the Cabal entry" + , (styleModule . fromString $ D.display mn) <> "," + , flow "but did find:" + , line <> bulletedList (map display possibilities) + , flow "If you are using a custom preprocessor for this module" + , flow "with its own file extension, consider adding the file(s)" + , flow "to your .cabal under extra-source-files." + ] where makePossibilities name = mapM @@ -1155,7 +1298,8 @@ -- If the directory contains a file named package.yaml, hpack is used to -- generate a .cabal file from it. findOrGenerateCabalFile - :: forall m. (MonadThrow m, MonadIO m, MonadLogger m) + :: forall m env. + (MonadIO m, MonadUnliftIO m, MonadLogger m, HasRunner env, HasConfig env, MonadReader env m) => Path Abs Dir -- ^ package directory -> m (Path Abs File) findOrGenerateCabalFile pkgDir = do @@ -1163,7 +1307,7 @@ findCabalFile where findCabalFile :: m (Path Abs File) - findCabalFile = findCabalFile' >>= either throwM return + findCabalFile = findCabalFile' >>= either throwIO return findCabalFile' :: m (Either PackageException (Path Abs File)) findCabalFile' = do @@ -1184,30 +1328,42 @@ where hasExtension fp x = FilePath.takeExtension fp == "." ++ x -- | Generate .cabal file from package.yaml, if necessary. -hpack :: (MonadIO m, MonadLogger m) => Path Abs Dir -> m () +hpack :: (MonadIO m, MonadUnliftIO m, MonadLogger m, HasRunner env, HasConfig env, MonadReader env m) + => Path Abs Dir -> m () hpack pkgDir = do let hpackFile = pkgDir $(mkRelFile Hpack.packageConfig) exists <- liftIO $ doesFileExist hpackFile when exists $ do - let fpt = T.pack (toFilePath hpackFile) - $logDebug $ "Running hpack on " <> fpt -#if MIN_VERSION_hpack(0,18,0) - r <- liftIO $ Hpack.hpackResult (Just $ toFilePath pkgDir) -#else - r <- liftIO $ Hpack.hpackResult (toFilePath pkgDir) -#endif - forM_ (Hpack.resultWarnings r) $ \w -> $logWarn ("WARNING: " <> T.pack w) - let cabalFile = T.pack (Hpack.resultCabalFile r) - case Hpack.resultStatus r of - Hpack.Generated -> $logDebug $ - "hpack generated a modified version of " <> cabalFile - Hpack.OutputUnchanged -> $logDebug $ - "hpack output unchanged in " <> cabalFile - -- NOTE: this is 'logInfo' so it will be outputted to the - -- user by default. - Hpack.AlreadyGeneratedByNewerHpack -> $logWarn $ - "WARNING: " <> cabalFile <> " was generated with a newer version of hpack, please upgrade and try again." + prettyDebugL [flow "Running hpack on", display hpackFile] + config <- view configL + case configOverrideHpack config of + HpackBundled -> do + r <- liftIO $ Hpack.hpackResult (Just $ toFilePath pkgDir) Hpack.NoForce + forM_ (Hpack.resultWarnings r) prettyWarnS + let cabalFile = styleFile . fromString . Hpack.resultCabalFile $ r + case Hpack.resultStatus r of + Hpack.Generated -> prettyDebugL + [flow "hpack generated a modified version of", cabalFile] + Hpack.OutputUnchanged -> prettyDebugL + [flow "hpack output unchanged in", cabalFile] + Hpack.AlreadyGeneratedByNewerHpack -> prettyWarnL + [ cabalFile + , flow "was generated with a newer version of hpack," + , flow "please upgrade and try again." + ] + Hpack.ExistingCabalFileWasModifiedManually -> prettyWarnL + [ flow "WARNING: " + , cabalFile + , flow " was modified manually. Ignoring package.yaml in favor of cabal file." + , flow "If you want to use package.yaml instead of the cabal file, " + , flow "then please delete the cabal file." + ] + HpackCommand command -> do + envOverride <- getMinimalEnvOverride + let cmd = Cmd (Just pkgDir) command envOverride [] + runCmd cmd Nothing + -- | Path for the package's build log. buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m) => Package -> Maybe String -> m (Path Abs File) @@ -1220,38 +1376,41 @@ return $ stack $(mkRelDir "logs") fp -- Internal helper to define resolveFileOrWarn and resolveDirOrWarn -resolveOrWarn :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) +resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader Ctx m) => Text -> (Path Abs Dir -> String -> m (Maybe a)) -> FilePath.FilePath -> m (Maybe a) resolveOrWarn subject resolver path = - do cwd <- getCurrentDir - file <- asks fst - dir <- asks (parent . fst) + do cwd <- liftIO getCurrentDir + file <- asks ctxFile + dir <- asks (parent . ctxFile) result <- resolver dir path when (isNothing result) $ - $logWarn ("Warning: " <> subject <> " listed in " <> - T.pack (maybe (FL.toFilePath file) FL.toFilePath (stripDir cwd file)) <> - " file does not exist: " <> - T.pack path) + prettyWarnL + [ fromString . T.unpack $ subject -- TODO: needs style? + , flow "listed in" + , maybe (display file) display (stripProperPrefix cwd file) + , flow "file does not exist:" + , styleDir . fromString $ path + ] return result -- | Resolve the file, if it can't be resolved, warn for the user -- (purely to be helpful). -resolveFileOrWarn :: (MonadCatch m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m) +resolveFileOrWarn :: (MonadIO m,MonadLogger m,MonadReader Ctx m) => FilePath.FilePath -> m (Maybe (Path Abs File)) resolveFileOrWarn = resolveOrWarn "File" f - where f p x = forgivingAbsence (resolveFile p x) >>= rejectMissingFile + where f p x = liftIO (forgivingAbsence (resolveFile p x)) >>= rejectMissingFile -- | Resolve the directory, if it can't be resolved, warn for the user -- (purely to be helpful). -resolveDirOrWarn :: (MonadCatch m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m) +resolveDirOrWarn :: (MonadIO m,MonadLogger m,MonadReader Ctx m) => FilePath.FilePath -> m (Maybe (Path Abs Dir)) resolveDirOrWarn = resolveOrWarn "Directory" f - where f p x = forgivingAbsence (resolveDir p x) >>= rejectMissingDir + where f p x = liftIO (forgivingAbsence (resolveDir p x)) >>= rejectMissingDir -- | Extract the @PackageIdentifier@ given an exploded haskell package -- path. @@ -1259,10 +1418,10 @@ :: (MonadIO m, MonadThrow m) => Path Abs File -> m PackageIdentifier cabalFilePackageId fp = do - pkgDescr <- liftIO (D.readPackageDescription D.silent $ toFilePath fp) + pkgDescr <- liftIO (D.readGenericPackageDescription D.silent $ toFilePath fp) (toStackPI . D.package . D.packageDescription) pkgDescr where - toStackPI (D.PackageIdentifier (D.PackageName name) ver) = do + toStackPI (D.PackageIdentifier (D.unPackageName -> name) ver) = do name' <- parsePackageNameFromString name ver' <- parseVersionFromString (showVersion ver) return (PackageIdentifier name' ver') diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} @@ -24,37 +25,21 @@ , pruneDeps ) where -import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Exception.Safe (tryIO) -import Control.Monad (liftM) -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Logger (MonadLogger) -import Control.Monad.Trans.Control +import Stack.Prelude import Data.Attoparsec.Args import Data.Attoparsec.Text as P import Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Conduit.Text as CT -import Data.Either (partitionEithers) -import Data.IORef import Data.List (isPrefixOf) -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 Data.Store.VersionTagged -import Data.Text (Text) import qualified Data.Text as T -import Data.Typeable (Typeable) import qualified Distribution.License as C import qualified Distribution.System as OS import qualified Distribution.Text as C -import Path import Path.Extra (toFilePathNoTrailingSep) -import Prelude -- Fix AMP warning import Stack.GhcPkg import Stack.Types.Compiler import Stack.Types.GhcPkgId @@ -67,7 +52,7 @@ -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global @@ -77,7 +62,7 @@ -- | Call ghc-pkg describe with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDescribe - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => PackageName -> EnvOverride -> WhichCompiler @@ -88,7 +73,7 @@ -- | Call ghc-pkg and stream to the given @Sink@, for a single database ghcPkgCmdArgs - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => [String] -> EnvOverride -> WhichCompiler @@ -117,7 +102,7 @@ -- | Load a @InstalledCache@ from disk, swallowing any errors and returning an -- empty cache. -loadInstalledCache :: (MonadLogger m, MonadIO m, MonadBaseControl IO m) +loadInstalledCache :: (MonadLogger m, MonadUnliftIO m) => Path Abs File -> m InstalledCache loadInstalledCache path = do m <- $(versionedDecodeOrLoad installedCacheVC) path (return $ InstalledCacheInner Map.empty) @@ -267,9 +252,11 @@ s <- case Map.lookup gid m of Just installed -> return (installedCacheSymbols installed) Nothing | null (dpLibraries dp) -> return True - Nothing -> do - let lib = T.unpack . head $ dpLibraries dp - liftM or . mapM (\dir -> liftIO $ hasDebuggingSymbols dir lib) $ dpLibDirs dp + Nothing -> + case dpLibraries dp of + [] -> return True + lib:_ -> + liftM or . mapM (\dir -> liftIO $ hasDebuggingSymbols dir (T.unpack lib)) $ dpLibDirs dp return dp { dpSymbols = s } hasDebuggingSymbols :: FilePath -- ^ library directory @@ -298,6 +285,7 @@ , dpLibDirs :: ![FilePath] , dpLibraries :: ![Text] , dpHasExposedModules :: !Bool + , dpExposedModules :: ![Text] , dpDepends :: ![GhcPkgId] , dpHaddockInterfaces :: ![FilePath] , dpHaddockHtml :: !(Maybe FilePath) @@ -384,6 +372,7 @@ , dpLibDirs = libDirPaths , dpLibraries = T.words $ T.unwords libraries , dpHasExposedModules = not (null libraries || null exposedModules) + , dpExposedModules = T.words $ T.unwords exposedModules , dpDepends = depends , dpHaddockInterfaces = haddockInterfaces , dpHaddockHtml = listToMaybe haddockHtml diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} @@ -21,47 +22,24 @@ module Stack.PackageIndex ( updateAllIndices , getPackageCaches - , getPackageCachesIO , getPackageVersions - , getPackageVersionsIO , lookupPackageVersions ) where import qualified Codec.Archive.Tar as Tar -import Control.Exception (Exception) -import Control.Exception.Safe (tryIO) -import Control.Monad (unless, when, liftM, void, guard) -import Control.Monad.Catch (throwM) -import qualified Control.Monad.Catch as C -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger (logDebug, logInfo, logWarn) -import Control.Monad.Trans.Control -import Crypto.Hash as Hash (hashlazy, Digest, SHA1) +import Stack.Prelude import Data.Aeson.Extended -import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16)) -import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L -import Data.Conduit (($$), (=$), (.|), runConduitRes) import Data.Conduit.Binary (sinkHandle, sourceHandle, sourceFile, sinkFile) import Data.Conduit.Zlib (ungzip) -import Data.Foldable (forM_) -import Data.IORef -import Data.Int (Int64) -import Data.HashMap.Strict (HashMap) +import qualified Data.List.NonEmpty as NE import qualified Data.HashMap.Strict as HashMap -import Data.Map (Map) -import qualified Data.Map.Strict as Map -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as Set import Data.Store.Version import Data.Store.VersionTagged -import Data.Text (Text) import qualified Data.Text as T import Data.Text.Unsafe (unsafeTail) import Data.Time (getCurrentTime) -import Data.Traversable (forM) -import Data.Typeable (Typeable) import qualified Hackage.Security.Client as HS import qualified Hackage.Security.Client.Repository.Cache as HS import qualified Hackage.Security.Client.Repository.Remote as HS @@ -72,113 +50,132 @@ import Network.HTTP.Download import Network.URI (parseURI) import Path (toFilePath, parseAbsFile) +import Path.Extra (tryGetModificationTime) import Path.IO -import Prelude -- Fix AMP warning -import Stack.Types.BuildPlan (GitSHA1 (..)) import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName -import Stack.Types.StackT -import Stack.Types.StringError import Stack.Types.Version import qualified System.Directory as D import System.FilePath ((<.>)) -import System.IO (IOMode (ReadMode, WriteMode), withBinaryFile) -- | Populate the package index caches and return them. -populateCache - :: (StackMiniM env m, HasConfig env) - => PackageIndex - -> m PackageCacheMap +populateCache :: HasConfig env => PackageIndex -> RIO env (PackageCache ()) populateCache index = do requireIndex index -- This uses full on lazy I/O instead of ResourceT to provide some -- protections. Caveat emptor path <- configPackageIndex (indexName index) - let loadPIS = do - $logSticky "Populating index cache ..." - lbs <- liftIO $ L.readFile $ Path.toFilePath path - loop 0 (Map.empty, HashMap.empty) (Tar.read lbs) - (pis, gitPIs) <- loadPIS `C.catch` \e -> do - $logWarn $ "Exception encountered when parsing index tarball: " + let loadPIS = withBinaryFile (Path.toFilePath path) ReadMode $ \h -> do + logSticky "Populating index cache ..." + lbs <- liftIO $ L.hGetContents h + loop 0 HashMap.empty (Tar.read lbs) + pis0 <- loadPIS `catch` \e -> do + logWarn $ "Exception encountered when parsing index tarball: " <> T.pack (show (e :: Tar.FormatError)) - $logWarn "Automatically updating index and trying again" + logWarn "Automatically updating index and trying again" updateIndex index loadPIS - when (indexRequireHashes index) $ forM_ (Map.toList pis) $ \(ident, pc) -> - case pcDownload pc of + when (indexRequireHashes index) $ forM_ (HashMap.toList pis0) $ \(ident, (mpd, _)) -> + case mpd :: Maybe PackageDownload of Just _ -> return () Nothing -> throwM $ MissingRequiredHashes (indexName index) ident - $logStickyDone "Populated index cache." + cache <- fmap mconcat $ mapM convertPI $ HashMap.toList pis0 - return $ PackageCacheMap pis gitPIs + logStickyDone "Populated index cache." + + return cache where - loop !blockNo (!m, !hm) (Tar.Next e es) = - loop (blockNo + entrySizeInBlocks e) (goE blockNo m hm e) es - loop _ (m, hm) Tar.Done = return (m, hm) + convertPI :: MonadIO m + => (PackageIdentifier, (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)])) + -> m (PackageCache ()) + convertPI (ident@(PackageIdentifier name version), (mpd, Endo front)) = + case NE.nonEmpty $ front [] of + Nothing -> throwString $ "Missing cabal file info for: " ++ show ident + Just files -> return + $ PackageCache + $ HashMap.singleton name + $ HashMap.singleton version + ((), mpd, files) + + loop :: MonadThrow m + => Int64 + -> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)]) + -> Tar.Entries Tar.FormatError + -> m (HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)])) + loop !blockNo !m (Tar.Next e es) = + loop (blockNo + entrySizeInBlocks e) (goE blockNo m e) es + loop _ m Tar.Done = return m loop _ _ (Tar.Fail e) = throwM e - goE blockNo m hm e = + goE :: Int64 + -> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)]) + -> Tar.Entry + -> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)]) + goE blockNo m e = case Tar.entryContent e of Tar.NormalFile lbs size -> case parseNameVersionSuffix $ Tar.entryPath e of Just (ident, ".cabal") -> addCabal lbs ident size - Just (ident, ".json") -> (addJSON id ident lbs, hm) + Just (ident, ".json") -> addJSON id ident lbs _ -> case parsePackageJSON $ Tar.entryPath e of - Just ident -> (addJSON unHSPackageDownload ident lbs, hm) - Nothing -> (m, hm) - _ -> (m, hm) + Just ident -> addJSON unHSPackageDownload ident lbs + Nothing -> m + _ -> m where - addCabal lbs ident size = - ( Map.insertWith - (\_ pcOld -> pcNew { pcDownload = pcDownload pcOld }) - ident - pcNew - m - , HashMap.insert gitSHA1 offsetSize hm - ) + addCabal lbs ident size = HashMap.alter + (\case + Nothing -> Just (Nothing, newEndo) + Just (mpd, oldEndo) -> Just (mpd, oldEndo <> newEndo)) + ident + m where - pcNew = PackageCache - { pcOffsetSize = offsetSize - , pcDownload = Nothing - } - offsetSize = OffsetSize - ((blockNo + 1) * 512) - size - - -- Calculate the Git SHA1 of the contents. This uses the - -- Git algorithm of prepending "blob \0" to the raw - -- contents. We use this to be able to share the same SHA - -- information between the Git and tarball backends. - gitSHA1 = GitSHA1 $ Mem.convertToBase Mem.Base16 $ hashSHA1 $ L.fromChunks - $ "blob " - : S8.pack (show $ L.length lbs) - : "\0" - : L.toChunks lbs + !cabalHash = computeCabalHash lbs - hashSHA1 :: L.ByteString -> Hash.Digest Hash.SHA1 - hashSHA1 = Hash.hashlazy + -- Some older Stackage snapshots ended up with slightly + -- modified cabal files, in particular having DOS-style + -- line endings (CRLF) converted to Unix-style (LF). As a + -- result, we track both hashes with and without CR + -- characters stripped for compatibility with these older + -- snapshots. + cr = 13 + cabalHashes + | cr `L.elem` lbs = + let !cabalHash' = computeCabalHash (L.filter (/= cr) lbs) + in [cabalHash, cabalHash'] + | otherwise = [cabalHash] + offsetSize = OffsetSize ((blockNo + 1) * 512) size + newPair = (cabalHashes, offsetSize) + newEndo = Endo (newPair:) addJSON :: FromJSON a => (a -> PackageDownload) -> PackageIdentifier -> L.ByteString - -> Map PackageIdentifier PackageCache + -> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)]) addJSON unwrap ident lbs = case decode lbs of Nothing -> m - Just (unwrap -> pd) -> Map.insertWith - (\_ pc -> pc { pcDownload = Just pd }) - ident - PackageCache - { pcOffsetSize = OffsetSize 0 0 - , pcDownload = Just pd - } - m + Just (unwrap -> pd) -> HashMap.alter + (\case + Nothing -> Just (Just pd, mempty) + Just (Just oldPD, _) + | oldPD /= pd -> error $ concat + [ "Conflicting package hash information discovered for " + , packageIdentifierString ident + , "\nFound both: \n- " + , show oldPD + , "\n- " + , show pd + , "\n\nThis should not happen. See: https://github.com/haskell/hackage-security/issues/189" + ] + Just (_, files) -> Just (Just pd, files)) + ident + m breakSlash x | T.null z = Nothing @@ -227,24 +224,24 @@ ] -- | Require that an index be present, updating if it isn't. -requireIndex :: (StackMiniM env m, HasConfig env) => PackageIndex -> m () +requireIndex :: HasConfig env => PackageIndex -> RIO env () requireIndex index = do tarFile <- configPackageIndex $ indexName index exists <- doesFileExist tarFile unless exists $ updateIndex index -- | Update all of the package indices -updateAllIndices :: (StackMiniM env m, HasConfig env) => m () +updateAllIndices :: HasConfig env => RIO env () updateAllIndices = do clearPackageCaches view packageIndicesL >>= mapM_ updateIndex -- | Update the index tarball -updateIndex :: (StackMiniM env m, HasConfig env) => PackageIndex -> m () +updateIndex :: HasConfig env => PackageIndex -> RIO env () updateIndex index = do let name = indexName index url = indexLocation index - $logSticky $ "Updating package index " + logSticky $ "Updating package index " <> indexNameText (indexName index) <> " (mirrored at " <> url @@ -252,61 +249,65 @@ case indexType index of ITVanilla -> updateIndexHTTP name url ITHackageSecurity hs -> updateIndexHackageSecurity name url hs + logStickyDone "Update complete" -- Copy to the 00-index.tar filename for backwards -- compatibility. First wipe out the cache file if present. tarFile <- configPackageIndex name oldTarFile <- configPackageIndexOld name oldCacheFile <- configPackageIndexCacheOld name - ignoringAbsence (removeFile oldCacheFile) - runConduitRes $ sourceFile (toFilePath tarFile) .| sinkFile (toFilePath oldTarFile) + liftIO $ ignoringAbsence (removeFile oldCacheFile) + liftIO $ runConduitRes $ sourceFile (toFilePath tarFile) .| sinkFile (toFilePath oldTarFile) -- | Update the index tarball via HTTP -updateIndexHTTP :: (StackMiniM env m, HasConfig env) +updateIndexHTTP :: HasConfig env => IndexName -> Text -- ^ url - -> m () + -> RIO env () updateIndexHTTP indexName' url = do req <- parseRequest $ T.unpack url - $logInfo ("Downloading package index from " <> url) + logInfo ("Downloading package index from " <> url) gz <- configPackageIndexGz indexName' tar <- configPackageIndex indexName' wasDownloaded <- redownload req gz - toUnpack <- + shouldUnpack <- if wasDownloaded then return True else not `liftM` doesFileExist tar - when toUnpack $ do - let tmp = toFilePath tar <.> "tmp" - tmpPath <- parseAbsFile tmp + if not shouldUnpack + then packageIndexNotUpdated indexName' + else do + let tmp = toFilePath tar <.> "tmp" + tmpPath <- parseAbsFile tmp - deleteCache indexName' + deleteCache indexName' - liftIO $ do - withBinaryFile (toFilePath gz) ReadMode $ \input -> - withBinaryFile tmp WriteMode $ \output -> - sourceHandle input - $$ ungzip - =$ sinkHandle output - renameFile tmpPath tar + liftIO $ do + withBinaryFile (toFilePath gz) ReadMode $ \input -> + withBinaryFile tmp WriteMode $ \output -> runConduit + $ sourceHandle input + .| ungzip + .| sinkHandle output + renameFile tmpPath tar -- | Update the index tarball via Hackage Security updateIndexHackageSecurity - :: (StackMiniM env m, HasConfig env) + :: HasConfig env => IndexName -> Text -- ^ base URL -> HackageSecurity - -> m () + -> RIO env () updateIndexHackageSecurity indexName' url (HackageSecurity keyIds threshold) = do baseURI <- case parseURI $ T.unpack url of - Nothing -> errorString $ "Invalid Hackage Security base URL: " ++ T.unpack url + Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url Just x -> return x manager <- liftIO getGlobalManager root <- configPackageIndexRoot indexName' - logTUF <- embed_ ($logInfo . T.pack . HS.pretty) - let withRepo = HS.withRepository + run <- askRunInIO + let logTUF = run . logInfo . T.pack . HS.pretty + withRepo = HS.withRepository (HS.makeHttpLib manager) [baseURI] HS.defaultRepoOpts @@ -333,6 +334,7 @@ HS.checkForUpdates repo (Just now) case didUpdate of + HS.NoUpdates -> packageIndexNotUpdated indexName' HS.HasUpdates -> do -- The index actually updated. Delete the old cache, and -- then move the temporary unpacked file to its real @@ -340,95 +342,73 @@ tar <- configPackageIndex indexName' deleteCache indexName' liftIO $ D.renameFile (toFilePath tar ++ "-tmp") (toFilePath tar) - $logInfo "Updated package list downloaded" - HS.NoUpdates -> $logInfo "No updates to your package list were found" + logInfo "Updated package index downloaded" +-- If the index is newer than the cache, delete it so that +-- the next 'getPackageCaches' call recomputes it. This +-- could happen if a prior run of stack updated the index, +-- but exited before deleting the cache. +-- +-- See https://github.com/commercialhaskell/stack/issues/3033 +packageIndexNotUpdated :: HasConfig env => IndexName -> RIO env () +packageIndexNotUpdated indexName' = do + mindexModTime <- tryGetModificationTime =<< configPackageIndex indexName' + mcacheModTime <- tryGetModificationTime =<< configPackageIndexCache indexName' + case (mindexModTime, mcacheModTime) of + (Right indexModTime, Right cacheModTime) | cacheModTime < indexModTime -> do + deleteCache indexName' + logInfo "No updates to your package index were found, but clearing the index cache as it is older than the index." + (Left _, _) -> do + deleteCache indexName' + logError "Error: No updates to your package index were found, but downloaded index is missing." + _ -> logInfo "No updates to your package index were found" + -- | Delete the package index cache -deleteCache - :: (StackMiniM env m, HasConfig env) - => IndexName -> m () +deleteCache :: HasConfig env => IndexName -> RIO env () deleteCache indexName' = do fp <- configPackageIndexCache indexName' eres <- liftIO $ tryIO $ removeFile fp case eres of - Left e -> $logDebug $ "Could not delete cache: " <> T.pack (show e) - Right () -> $logDebug $ "Deleted index cache at " <> T.pack (toFilePath fp) - --- | Lookup a package's versions from 'IO'. -getPackageVersionsIO - :: (StackMiniM env m, HasConfig env) - => m (PackageName -> IO (Set Version)) -getPackageVersionsIO = do - getCaches <- getPackageCachesIO - return $ \name -> - fmap (lookupPackageVersions name . fst) getCaches + Left e -> logDebug $ "Could not delete cache: " <> T.pack (show e) + Right () -> logDebug $ "Deleted index cache at " <> T.pack (toFilePath fp) -- | Get the known versions for a given package from the package caches. -- -- See 'getPackageCaches' for performance notes. -getPackageVersions - :: (StackMiniM env m, HasConfig env) - => PackageName - -> m (Set Version) -getPackageVersions pkgName = - fmap (lookupPackageVersions pkgName . fst) getPackageCaches - -lookupPackageVersions :: PackageName -> Map PackageIdentifier a -> Set Version -lookupPackageVersions pkgName pkgCaches = - Set.fromList [v | PackageIdentifier n v <- Map.keys pkgCaches, n == pkgName] +getPackageVersions :: HasConfig env => PackageName -> RIO env (Set Version) +getPackageVersions pkgName = fmap (lookupPackageVersions pkgName) getPackageCaches --- | Access the package caches from 'IO'. --- --- FIXME: This is a temporary solution until a better solution --- to access the package caches from Stack.Build.ConstructPlan --- has been found. -getPackageCachesIO - :: (StackMiniM env m, HasConfig env) - => m (IO ( Map PackageIdentifier (PackageIndex, PackageCache) - , HashMap GitSHA1 (PackageIndex, OffsetSize))) -getPackageCachesIO = toIO getPackageCaches - where - toIO :: (MonadIO m, MonadBaseControl IO m) => m a -> m (IO a) - toIO m = do - runInBase <- liftBaseWith $ \run -> return (void . run) - return $ do - i <- newIORef (error "Impossible evaluation in toIO") - runInBase $ do - x <- m - liftIO $ writeIORef i x - readIORef i +lookupPackageVersions :: PackageName -> PackageCache index -> Set Version +lookupPackageVersions pkgName (PackageCache m) = + maybe Set.empty (Set.fromList . HashMap.keys) $ HashMap.lookup pkgName m -- | Load the package caches, or create the caches if necessary. -- -- This has two levels of caching: in memory, and the on-disk cache. So, -- feel free to call this function multiple times. -getPackageCaches - :: (StackMiniM env m, HasConfig env) - => m ( Map PackageIdentifier (PackageIndex, PackageCache) - , HashMap GitSHA1 (PackageIndex, OffsetSize) - ) +getPackageCaches :: HasConfig env => RIO env (PackageCache PackageIndex) getPackageCaches = do config <- view configL - mcached <- liftIO $ readIORef (configPackageCaches config) + mcached <- liftIO $ readIORef (configPackageCache config) case mcached of Just cached -> return cached Nothing -> do result <- liftM mconcat $ forM (configPackageIndices config) $ \index -> do fp <- configPackageIndexCache (indexName index) - PackageCacheMap pis' gitPIs <- - $(versionedDecodeOrLoad (storeVersionConfig "pkg-v2" "WlAvAaRXlIMkjSmg5G3dD16UpT8=" - :: VersionConfig PackageCacheMap)) + PackageCache pis <- + $(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "A607WaDwhg5VVvZTxNgU9g52DO8=" + :: VersionConfig (PackageCache ()))) fp (populateCache index) - return (fmap (index,) pis', fmap (index,) gitPIs) - liftIO $ writeIORef (configPackageCaches config) (Just result) + return $ PackageCache ((fmap.fmap) (\((), mpd, files) -> (index, mpd, files)) pis) + liftIO $ writeIORef (configPackageCache config) (Just result) return result -- | Clear the in-memory hackage index cache. This is needed when the -- hackage index is updated. -clearPackageCaches :: (StackMiniM env m, HasConfig env) => m () +clearPackageCaches :: HasConfig env => RIO env () clearPackageCaches = do - cacheRef <- view packageCachesL + cacheRef <- view $ configL.to configPackageCache liftIO $ writeIORef cacheRef Nothing --------------- Lifted from cabal-install, Distribution.Client.Tar: diff --git a/src/Stack/PackageLocation.hs b/src/Stack/PackageLocation.hs new file mode 100644 --- /dev/null +++ b/src/Stack/PackageLocation.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | Deal with downloading, cloning, or whatever else is necessary for +-- getting a 'PackageLocation' into something Stack can work with. +module Stack.PackageLocation + ( resolveSinglePackageLocation + , resolveMultiPackageLocation + , parseSingleCabalFile + , parseSingleCabalFileIndex + , parseMultiCabalFiles + , parseMultiCabalFilesIndex + ) where + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Zip as Zip +import qualified Codec.Compression.GZip as GZip +import Stack.Prelude +import Crypto.Hash (hashWith, SHA256(..)) +import qualified Data.ByteArray as Mem (convert) +import qualified Data.ByteString as S +import qualified Data.ByteString.Base64.URL as B64URL +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Distribution.PackageDescription (GenericPackageDescription) +import Network.HTTP.Client (parseUrlThrow) +import Network.HTTP.Download.Verified +import Path +import Path.Extra +import Path.IO +import Stack.Package +import Stack.Types.BuildPlan +import Stack.Types.Config +import Stack.Types.PackageIdentifier +import qualified System.Directory as Dir +import System.Process.Read +import System.Process.Run + +-- | Same as 'resolveMultiPackageLocation', but works on a +-- 'SinglePackageLocation'. +resolveSinglePackageLocation + :: HasConfig env + => Path Abs Dir -- ^ project root + -> PackageLocation FilePath + -> RIO env (Path Abs Dir) +resolveSinglePackageLocation projRoot (PLFilePath fp) = resolveDir projRoot fp +resolveSinglePackageLocation projRoot (PLArchive (Archive url subdir msha)) = do + workDir <- view workDirL + + -- TODO: dedupe with code for snapshot hash? + let name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 url + root = projRoot workDir $(mkRelDir "downloaded") + fileExtension' = ".http-archive" + + fileRel <- parseRelFile $ name ++ fileExtension' + dirRel <- parseRelDir name + dirRelTmp <- parseRelDir $ name ++ ".tmp" + let fileDownload = root fileRel + dir = root dirRel + + exists <- doesDirExist dir + unless exists $ do + liftIO $ ignoringAbsence (removeDirRecur dir) + + let dirTmp = root dirRelTmp + liftIO $ ignoringAbsence (removeDirRecur dirTmp) + + urlExists <- liftIO $ Dir.doesFileExist $ T.unpack url + file <- + if urlExists + then do + file <- liftIO $ Dir.canonicalizePath (T.unpack url) >>= parseAbsFile + case msha of + Nothing -> return () + Just sha -> do + actualSha <- mkStaticSHA256FromFile file + when (sha /= actualSha) $ error $ concat + [ "Invalid SHA256 found for local archive " + , show file + , "\nExpected: " + , T.unpack $ staticSHA256ToText sha + , "\nActual: " + , T.unpack $ staticSHA256ToText actualSha + ] + return file + else do + req <- parseUrlThrow $ T.unpack url + let dreq = DownloadRequest + { drRequest = req + , drHashChecks = + case msha of + Nothing -> [] + Just sha -> + [HashCheck + { hashCheckAlgorithm = SHA256 + , hashCheckHexDigest = CheckHexDigestByteString $ staticSHA256ToBase16 sha + }] + , drLengthCheck = Nothing -- TODO add length info? + , drRetryPolicy = drRetryPolicyDefault + } + _ <- verifiedDownload dreq fileDownload (const $ return ()) + return fileDownload + + let fp = toFilePath file + + let tryTar = do + logDebug $ "Trying to untar " <> T.pack fp + liftIO $ withBinaryFile fp ReadMode $ \h -> do + lbs <- L.hGetContents h + let entries = Tar.read $ GZip.decompress lbs + Tar.unpack (toFilePath dirTmp) entries + tryZip = do + logDebug $ "Trying to unzip " <> T.pack fp + archive <- fmap Zip.toArchive $ liftIO $ L.readFile fp + liftIO $ Zip.extractFilesFromArchive [Zip.OptDestination + (toFilePath dirTmp)] archive + err = throwM $ UnableToExtractArchive url file + + catchAnyLog goodpath handler = + catchAny goodpath $ \e -> do + logDebug $ "Got exception: " <> T.pack (show e) + handler + + tryTar `catchAnyLog` tryZip `catchAnyLog` err + renameDir dirTmp dir + + x <- listDir dir + case x of + ([dir'], []) -> resolveDir dir' subdir + (dirs, files) -> liftIO $ do + ignoringAbsence (removeFile fileDownload) + ignoringAbsence (removeDirRecur dir) + throwIO $ UnexpectedArchiveContents dirs files +resolveSinglePackageLocation projRoot (PLRepo (Repo url commit repoType' subdir)) = + cloneRepo projRoot url commit repoType' >>= flip resolveDir subdir + +-- | Resolve a PackageLocation into a path, downloading and cloning as +-- necessary. +-- +-- Returns the updated PackageLocation value with just a single subdir +-- (if relevant). +resolveMultiPackageLocation + :: HasConfig env + => Path Abs Dir -- ^ project root + -> PackageLocation Subdirs + -> RIO env [(Path Abs Dir, PackageLocation FilePath)] +resolveMultiPackageLocation y (PLFilePath fp) = do + dir <- resolveSinglePackageLocation y (PLFilePath fp) + return [(dir, PLFilePath fp)] +resolveMultiPackageLocation y (PLArchive (Archive url subdirs msha)) = do + dir <- resolveSinglePackageLocation y (PLArchive (Archive url "." msha)) + let subdirs' = + case subdirs of + DefaultSubdirs -> ["."] + ExplicitSubdirs subs -> subs + forM subdirs' $ \subdir -> do + dir' <- resolveDir dir subdir + return (dir', PLArchive (Archive url subdir msha)) +resolveMultiPackageLocation projRoot (PLRepo (Repo url commit repoType' subdirs)) = do + dir <- cloneRepo projRoot url commit repoType' + + let subdirs' = + case subdirs of + DefaultSubdirs -> ["."] + ExplicitSubdirs subs -> subs + forM subdirs' $ \subdir -> do + dir' <- resolveDir dir subdir + return (dir', PLRepo $ Repo url commit repoType' subdir) + +cloneRepo + :: HasConfig env + => Path Abs Dir -- ^ project root + -> Text -- ^ URL + -> Text -- ^ commit + -> RepoType + -> RIO env (Path Abs Dir) +cloneRepo projRoot url commit repoType' = do + workDir <- view workDirL + let nameBeforeHashing = case repoType' of + RepoGit -> T.unwords [url, commit] + RepoHg -> T.unwords [url, commit, "hg"] + -- TODO: dedupe with code for snapshot hash? + name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 nameBeforeHashing + root = projRoot workDir $(mkRelDir "downloaded") + + dirRel <- parseRelDir name + let dir = root dirRel + + exists <- doesDirExist dir + unless exists $ do + liftIO $ ignoringAbsence (removeDirRecur dir) + menv <- getMinimalEnvOverride + + let cloneAndExtract commandName cloneArgs resetCommand = do + ensureDir root + logInfo $ "Cloning " <> commit <> " from " <> url + callProcessInheritStderrStdout Cmd + { cmdDirectoryToRunIn = Just root + , cmdCommandToRun = commandName + , cmdEnvOverride = menv + , cmdCommandLineArguments = + "clone" : + cloneArgs ++ + [ T.unpack url + , toFilePathNoTrailingSep dir + ] + } + created <- doesDirExist dir + unless created $ throwM $ FailedToCloneRepo commandName + readProcessNull (Just dir) menv commandName + (resetCommand ++ [T.unpack commit, "--"]) + `catch` \case + ex@ProcessFailed{} -> do + logInfo $ "Please ensure that commit " <> commit <> " exists within " <> url + throwM ex + ex -> throwM ex + + case repoType' of + RepoGit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"] + RepoHg -> cloneAndExtract "hg" [] ["--repository", ".", "update", "-C"] + + return dir + +-- | Parse the cabal files present in the given +-- 'PackageLocationIndex FilePath'. +parseSingleCabalFileIndex + :: forall env. + HasConfig env + => (PackageIdentifierRevision -> IO ByteString) -- ^ lookup in index + -> Path Abs Dir -- ^ project root, used for checking out necessary files + -> PackageLocationIndex FilePath + -> RIO env GenericPackageDescription +-- Need special handling of PLIndex for efficiency (just read from the +-- index tarball) and correctness (get the cabal file from the index, +-- not the package tarball itself, yay Hackage revisions). +parseSingleCabalFileIndex loadFromIndex _ (PLIndex pir) = readPackageUnresolvedIndex loadFromIndex pir +parseSingleCabalFileIndex _ root (PLOther loc) = lpvGPD <$> parseSingleCabalFile root False loc + +parseSingleCabalFile + :: forall env. HasConfig env + => Path Abs Dir -- ^ project root, used for checking out necessary files + -> Bool -- ^ print warnings? + -> PackageLocation FilePath + -> RIO env LocalPackageView +parseSingleCabalFile root printWarnings loc = do + dir <- resolveSinglePackageLocation root loc + (gpd, cabalfp) <- readPackageUnresolvedDir dir printWarnings + return LocalPackageView + { lpvCabalFP = cabalfp + , lpvGPD = gpd + , lpvLoc = loc + } + +-- | Load and parse cabal files into 'GenericPackageDescription's +parseMultiCabalFiles + :: forall env. HasConfig env + => Path Abs Dir -- ^ project root, used for checking out necessary files + -> Bool -- ^ print warnings? + -> PackageLocation Subdirs + -> RIO env [LocalPackageView] +parseMultiCabalFiles root printWarnings loc0 = + resolveMultiPackageLocation root loc0 >>= + mapM (\(dir, loc1) -> do + (gpd, cabalfp) <- readPackageUnresolvedDir dir printWarnings + return LocalPackageView + { lpvCabalFP = cabalfp + , lpvGPD = gpd + , lpvLoc = loc1 + }) + +-- | 'parseMultiCabalFiles' but supports 'PLIndex' +parseMultiCabalFilesIndex + :: forall env. HasConfig env + => (PackageIdentifierRevision -> IO ByteString) + -> Path Abs Dir -- ^ project root, used for checking out necessary files + -> PackageLocationIndex Subdirs + -> RIO env [(GenericPackageDescription, PackageLocationIndex FilePath)] +parseMultiCabalFilesIndex loadFromIndex _root (PLIndex pir) = + (pure . (, PLIndex pir)) <$> + readPackageUnresolvedIndex loadFromIndex pir +parseMultiCabalFilesIndex _ root (PLOther loc0) = + map (\lpv -> (lpvGPD lpv, PLOther $ lpvLoc lpv)) <$> + parseMultiCabalFiles root False loc0 diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,15 +8,9 @@ , pathParser ) where -import Control.Monad.Catch -import Control.Monad.Logger -import Control.Monad.Reader -import Control.Monad.Trans.Control +import Stack.Prelude import Data.List (intercalate) -import Data.Maybe.Extra -import Data.Monoid import qualified Data.Set as Set -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Lens.Micro (lens) @@ -23,8 +18,10 @@ import Path import Path.Extra import Stack.Constants +import Stack.Constants.Config import Stack.GhcPkg as GhcPkg import Stack.Types.Config +import Stack.Types.Runner import qualified System.FilePath as FP import System.IO (stderr) import System.Process.Read (EnvOverride(eoPath)) @@ -32,8 +29,8 @@ -- | Print out useful path information in a human-readable format (and -- support others later). path - :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasEnvConfig env, - MonadCatch m, MonadLogger m) + :: (MonadUnliftIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, + MonadLogger m) => [Text] -> m () path keys = @@ -53,6 +50,7 @@ global <- GhcPkg.getGlobalDB menv whichCompiler snaproot <- installationRootDeps localroot <- installationRootLocal + toolsDir <- bindirCompilerTools distDir <- distRelativeDir hpcDir <- hpcReportDir compiler <- getCompilerPath whichCompiler @@ -86,6 +84,7 @@ global snaproot localroot + toolsDir distDir hpcDir extra @@ -110,6 +109,7 @@ , piGlobalDb :: Path Abs Dir , piSnapRoot :: Path Abs Dir , piLocalRoot :: Path Abs Dir + , piToolsDir :: Path Abs Dir , piDistDir :: Path Rel Dir , piHpcDir :: Path Abs Dir , piExtraDbs :: [Path Abs Dir] @@ -117,6 +117,10 @@ } instance HasPlatform PathInfo +instance HasLogFunc PathInfo where + logFuncL = configL.logFuncL +instance HasRunner PathInfo where + runnerL = configL.runnerL instance HasConfig PathInfo instance HasBuildConfig PathInfo where buildConfigL = lens piBuildConfig (\x y -> x { piBuildConfig = y }) @@ -154,6 +158,9 @@ , ( "Directory containing the compiler binary (e.g. ghc)" , "compiler-bin" , T.pack . toFilePathNoTrailingSep . parent . piCompiler ) + , ( "Directory containing binaries specific to a particular compiler (e.g. intero)" + , "compiler-tools-bin" + , T.pack . toFilePathNoTrailingSep . piToolsDir ) , ( "Local bin dir where stack installs executables (e.g. ~/.local/bin)" , "local-bin" , view $ configL.to configLocalBin.to toFilePathNoTrailingSep.to T.pack) diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Prelude.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Stack.Prelude + ( mapLeft + , ResourceT + , runConduitRes + , runResourceT + , liftResourceT + , NoLogging (..) + , withSystemTempDir + , fromFirst + , mapMaybeA + , mapMaybeM + , forMaybeA + , forMaybeM + , stripCR + , logSticky + , logStickyDone + , RIO (..) + , runRIO + , HasLogFunc (..) + , module X + ) where + +import Control.Applicative as X (Alternative, Applicative (..), + liftA, liftA2, liftA3, many, + optional, some, (<|>)) +import Control.Arrow as X (first, second, (&&&), (***)) +import Control.DeepSeq as X (NFData (..), force, ($!!)) +import Control.Monad as X (Monad (..), MonadPlus (..), filterM, + foldM, foldM_, forever, guard, join, + liftM, liftM2, replicateM_, unless, + when, zipWithM, zipWithM_, (<$!>), + (<=<), (=<<), (>=>)) +import Control.Monad.Catch as X (MonadThrow (..)) +import Control.Monad.Logger.CallStack + as X (Loc, LogLevel (..), LogSource, + LogStr, MonadLogger (..), + MonadLoggerIO (..), liftLoc, + logDebug, logError, logInfo, + logOther, logWarn, toLogStr) +import Control.Monad.Reader as X (MonadReader, MonadTrans (..), + ReaderT (..), ask, asks) +import Data.Bool as X (Bool (..), not, otherwise, (&&), + (||)) +import Data.ByteString as X (ByteString) +import Data.Char as X (Char) +import Data.Conduit as X (ConduitM, runConduit, (.|)) +import Data.Data as X (Data (..)) +import Data.Either as X (Either (..), either, isLeft, + isRight, lefts, partitionEithers, + rights) +import Data.Eq as X (Eq (..)) +import Data.Foldable as X (Foldable, all, and, any, asum, + concat, concatMap, elem, fold, + foldMap, foldl', foldr, forM_, for_, + length, mapM_, msum, notElem, null, + or, product, sequenceA_, sequence_, + sum, toList, traverse_) +import Data.Function as X (const, fix, flip, id, on, ($), (&), + (.)) +import Data.Functor as X (Functor (..), void, ($>), (<$), + (<$>)) +import Data.Hashable as X (Hashable) +import Data.HashMap.Strict as X (HashMap) +import Data.HashSet as X (HashSet) +import Data.Int as X +import Data.IntMap.Strict as X (IntMap) +import Data.IntSet as X (IntSet) +import Data.List as X (break, drop, dropWhile, filter, + lines, lookup, map, replicate, + reverse, span, take, takeWhile, + unlines, unwords, words, zip, (++)) +import Data.Map.Strict as X (Map) +import Data.Maybe as X (Maybe (..), catMaybes, fromMaybe, + isJust, isNothing, listToMaybe, + mapMaybe, maybe, maybeToList) +import Data.Monoid as X (All (..), Any (..), Endo (..), + First (..), Last (..), Monoid (..), + Product (..), Sum (..), (<>)) +import Data.Ord as X (Ord (..), Ordering (..), comparing) +import Data.Set as X (Set) +import Data.Store as X (Store) +import Data.String as X (IsString (..)) +import Data.Text as X (Text) +import Data.Traversable as X (Traversable (..), for, forM) +import Data.Vector as X (Vector) +import Data.Void as X (Void, absurd) +import Data.Word as X +import GHC.Generics as X (Generic) +import GHC.Stack as X (HasCallStack) +import Lens.Micro as X (Getting) +import Lens.Micro.Mtl as X (view) +import Path as X (Abs, Dir, File, Path, Rel, + toFilePath) +import Prelude as X (Bounded (..), Double, Enum, + FilePath, Float, Floating (..), + Fractional (..), IO, Integer, + Integral (..), Num (..), Rational, + Real (..), RealFloat (..), + RealFrac (..), Show, String, + asTypeOf, curry, error, even, + fromIntegral, fst, gcd, lcm, odd, + realToFrac, seq, show, snd, + subtract, uncurry, undefined, ($!), + (^), (^^)) +import Text.Read as X (Read, readMaybe) +import UnliftIO as X + +import qualified Data.Text as T +import qualified Path.IO + +import qualified Control.Monad.Trans.Resource as Res (runResourceT, transResourceT) +import Control.Monad.Trans.Resource.Internal (ResourceT (ResourceT)) + +mapLeft :: (a1 -> a2) -> Either a1 b -> Either a2 b +mapLeft f (Left a1) = Left (f a1) +mapLeft _ (Right b) = Right b + +fromFirst :: a -> First a -> a +fromFirst x = fromMaybe x . getFirst + +-- | 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 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 + +-- | Strip trailing carriage return from Text +stripCR :: T.Text -> T.Text +stripCR t = fromMaybe t (T.stripSuffix "\r" t) + +runConduitRes :: MonadUnliftIO m => ConduitM () Void (ResourceT m) r -> m r +runConduitRes = runResourceT . runConduit + +runResourceT :: MonadUnliftIO m => ResourceT m a -> m a +runResourceT r = withRunInIO $ \run -> Res.runResourceT (Res.transResourceT run r) + +liftResourceT :: MonadIO m => ResourceT IO a -> ResourceT m a +liftResourceT (ResourceT f) = ResourceT $ liftIO . f + +-- | Avoid orphan messes +newtype NoLogging a = NoLogging { runNoLogging :: IO a } + deriving (Functor, Applicative, Monad, MonadIO) +instance MonadUnliftIO NoLogging where + askUnliftIO = NoLogging $ + withUnliftIO $ \u -> + return (UnliftIO (unliftIO u . runNoLogging)) +instance MonadLogger NoLogging where + monadLoggerLog _ _ _ _ = return () + +-- | Path version +withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a +withSystemTempDir str inner = withRunInIO $ \run -> Path.IO.withSystemTempDir str $ run . inner + +-- | Write a "sticky" line to the terminal. Any subsequent lines will +-- overwrite this one, and that same line will be repeated below +-- again. In other words, the line sticks at the bottom of the output +-- forever. Running this function again will replace the sticky line +-- with a new sticky line. When you want to get rid of the sticky +-- line, run 'logStickyDone'. +-- +logSticky :: MonadLogger m => Text -> m () +logSticky = + logOther (LevelOther "sticky") + +-- | This will print out the given message with a newline and disable +-- any further stickiness of the line until a new call to 'logSticky' +-- happens. +-- +-- It might be better at some point to have a 'runSticky' function +-- that encompasses the logSticky->logStickyDone pairing. +logStickyDone :: MonadLogger m => Text -> m () +logStickyDone = + logOther (LevelOther "sticky-done") + +-- | The Reader+IO monad. This is different from a 'ReaderT' because: +-- +-- * It's not a transformer, it hardcodes IO for simpler usage and +-- error messages. +-- +-- * Instances of typeclasses like 'MonadLogger' are implemented using +-- classes defined on the environment, instead of using an +-- underlying monad. +newtype RIO env a = RIO { unRIO :: ReaderT env IO a } + deriving (Functor,Applicative,Monad,MonadIO,MonadReader env,MonadThrow) + +runRIO :: MonadIO m => env -> RIO env a -> m a +runRIO env (RIO (ReaderT f)) = liftIO (f env) + +class HasLogFunc env where + logFuncL :: Getting r env (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + +instance HasLogFunc env => MonadLogger (RIO env) where + monadLoggerLog a b c d = do + f <- view logFuncL + liftIO $ f a b c $ toLogStr d + +instance HasLogFunc env => MonadLoggerIO (RIO env) where + askLoggerIO = view logFuncL + +instance MonadUnliftIO (RIO env) where + askUnliftIO = RIO $ ReaderT $ \r -> + withUnliftIO $ \u -> + return (UnliftIO (unliftIO u . flip runReaderT r . unRIO)) diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,16 +9,20 @@ -- * Pretty printing functions displayPlain, displayWithColor -- * Logging based on pretty-print typeclass - , prettyDebug, prettyInfo, prettyWarn, prettyError - , debugBracket - -- * Color utils - -- | These are preferred to colors directly, so that we can - -- encourage consistency of color meanings. - , errorRed, goodGreen, shellMagenta - , displayTargetPkgId, displayCurrentPkgId, displayCurrentPkgName, displayErrorPkgId + , prettyDebug, prettyInfo, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent + , prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL + , prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS + -- * Semantic styling functions + -- | These are preferred to styling or colors directly, so that we can + -- encourage consistency. + , styleWarning, styleError, styleGood + , styleShell, styleFile, styleUrl, styleDir, styleModule + , styleCurrent, styleTarget , displayMilliseconds -- * Formatting utils , bulletedList + , spacedBulletedList + , debugBracket -- * Re-exports from "Text.PrettyPrint.Leijen.Extended" , Display(..), AnsiDoc, AnsiAnn(..), HasAnsiAnn(..), Doc , nest, line, linebreak, group, softline, softbreak @@ -27,98 +31,169 @@ , hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate , fill, fillBreak , enclose, squotes, dquotes, parens, angles, braces, brackets + , indentAfterLabel, wordDocs, flow ) where -import Control.Exception.Lifted -import Control.Monad.Logger -import Control.Monad.Reader +import Stack.Prelude import Data.List (intersperse) -import Data.Monoid -import Data.String (fromString) import qualified Data.Text as T -import Language.Haskell.TH -import Path -import Stack.Types.Internal +import Stack.Types.Config import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName +import Stack.Types.Runner import Stack.Types.Version import qualified System.Clock as Clock import Text.PrettyPrint.Leijen.Extended displayWithColor - :: (HasLogOptions env, MonadReader env m, Display a, HasAnsiAnn (Ann a)) + :: (HasRunner env, Display a, HasAnsiAnn (Ann a), + MonadReader env m, MonadLogger m) => a -> m T.Text displayWithColor x = do useAnsi <- liftM logUseColor $ view logOptionsL - return $ if useAnsi then displayAnsi x else displayPlain x + termWidth <- liftM logTermWidth $ view logOptionsL + return $ (if useAnsi then displayAnsi else displayPlain) termWidth x -- TODO: switch to using implicit callstacks once 7.8 support is dropped -prettyDebug :: Q Exp -prettyDebug = do - loc <- location - [e| monadLoggerLog loc "" LevelDebug <=< displayWithColor |] +prettyWith :: (HasRunner env, HasCallStack, Display b, HasAnsiAnn (Ann b), + MonadReader env m, MonadLogger m) + => LogLevel -> (a -> b) -> a -> m () +prettyWith level f = logOther level <=< displayWithColor . f -prettyInfo :: Q Exp -prettyInfo = do - loc <- location - [e| monadLoggerLog loc "" LevelInfo <=< displayWithColor |] +-- Note: I think keeping this section aligned helps spot errors, might be +-- worth keeping the alignment in place. -prettyWarn :: Q Exp -prettyWarn = do - loc <- location - [e| monadLoggerLog loc "" LevelWarn <=< displayWithColor . (line <>) . (warningYellow "Warning:" <+>) |] +prettyDebugWith, prettyInfoWith, prettyWarnWith, prettyErrorWith, prettyWarnNoIndentWith, prettyErrorNoIndentWith + :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) + => (a -> Doc AnsiAnn) -> a -> m () +prettyDebugWith = prettyWith LevelDebug +prettyInfoWith = prettyWith LevelInfo +prettyWarnWith f = prettyWith LevelWarn + ((line <>) . (styleWarning "Warning:" <+>) . + indentAfterLabel . f) +prettyErrorWith f = prettyWith LevelError + ((line <>) . (styleError "Error:" <+>) . + indentAfterLabel . f) +prettyWarnNoIndentWith f = prettyWith LevelWarn + ((line <>) . (styleWarning "Warning:" <+>) . f) +prettyErrorNoIndentWith f = prettyWith LevelWarn + ((line <>) . (styleError "Error:" <+>) . f) -prettyError :: Q Exp -prettyError = do - loc <- location - [e| monadLoggerLog loc "" LevelError <=< displayWithColor . (line <>) . (errorRed "Error:" <+>) |] +prettyDebug, prettyInfo, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent + :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) + => Doc AnsiAnn -> m () +prettyDebug = prettyDebugWith id +prettyInfo = prettyInfoWith id +prettyWarn = prettyWarnWith id +prettyError = prettyErrorWith id +prettyWarnNoIndent = prettyWarnNoIndentWith id +prettyErrorNoIndent = prettyErrorNoIndentWith id -debugBracket :: Q Exp -debugBracket = do - loc <- location - [e| \msg f -> do - let output = monadLoggerLog loc "" LevelDebug <=< displayWithColor - output $ "Start: " <> msg - start <- liftIO $ Clock.getTime Clock.Monotonic - x <- f `catch` \ex -> do - end <- liftIO $ Clock.getTime Clock.Monotonic - let diff = Clock.diffTimeSpec start end - output $ "Finished with exception in" <+> displayMilliseconds diff <> ":" <+> - msg <> line <> - "Exception thrown: " <> fromString (show ex) - throw (ex :: SomeException) - end <- liftIO $ Clock.getTime Clock.Monotonic - let diff = Clock.diffTimeSpec start end - output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg - return x - |] +prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL + :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) + => [Doc AnsiAnn] -> m () +prettyDebugL = prettyDebugWith fillSep +prettyInfoL = prettyInfoWith fillSep +prettyWarnL = prettyWarnWith fillSep +prettyErrorL = prettyErrorWith fillSep +prettyWarnNoIndentL = prettyWarnNoIndentWith fillSep +prettyErrorNoIndentL = prettyErrorNoIndentWith fillSep -errorRed :: AnsiDoc -> AnsiDoc -errorRed = dullred +prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS + :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) + => String -> m () +prettyDebugS = prettyDebugWith flow +prettyInfoS = prettyInfoWith flow +prettyWarnS = prettyWarnWith flow +prettyErrorS = prettyErrorWith flow +prettyWarnNoIndentS = prettyWarnNoIndentWith flow +prettyErrorNoIndentS = prettyErrorNoIndentWith flow -warningYellow :: AnsiDoc -> AnsiDoc -warningYellow = yellow +-- End of aligned section -goodGreen :: AnsiDoc -> AnsiDoc -goodGreen = green +-- | Use after a label and before the rest of what's being labelled for +-- consistent spacing/indenting/etc. +-- +-- For example this is used after "Warning:" in warning messages. +indentAfterLabel :: Doc a -> Doc a +indentAfterLabel = align -shellMagenta :: AnsiDoc -> AnsiDoc -shellMagenta = magenta +-- | Make a 'Doc' from each word in a 'String' +wordDocs :: String -> [Doc a] +wordDocs = map fromString . words -displayTargetPkgId :: PackageIdentifier -> AnsiDoc -displayTargetPkgId = cyan . display +-- | Wordwrap a 'String' +flow :: String -> Doc a +flow = fillSep . wordDocs -displayCurrentPkgId :: PackageIdentifier -> AnsiDoc -displayCurrentPkgId = yellow . display +debugBracket :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m, + MonadIO m, MonadUnliftIO m) => Doc AnsiAnn -> m a -> m a +debugBracket msg f = do + let output = logDebug <=< displayWithColor + output $ "Start: " <> msg + start <- liftIO $ Clock.getTime Clock.Monotonic + x <- f `catch` \ex -> do + end <- liftIO $ Clock.getTime Clock.Monotonic + let diff = Clock.diffTimeSpec start end + output $ "Finished with exception in" <+> displayMilliseconds diff <> ":" <+> + msg <> line <> + "Exception thrown: " <> fromString (show ex) + throwIO (ex :: SomeException) + end <- liftIO $ Clock.getTime Clock.Monotonic + let diff = Clock.diffTimeSpec start end + output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg + return x -displayCurrentPkgName :: PackageName -> AnsiDoc -displayCurrentPkgName = yellow . display +-- | Style an 'AnsiDoc' as an error. Should be used sparingly, not to style +-- entire long messages. For example, it's used to style the "Error:" +-- label for an error message, not the entire message. +styleError :: AnsiDoc -> AnsiDoc +styleError = dullred -displayErrorPkgId :: PackageIdentifier -> AnsiDoc -displayErrorPkgId = errorRed . display +-- | Style an 'AnsiDoc' as a warning. Should be used sparingly, not to style +-- entire long messages. For example, it's used to style the "Warning:" +-- label for an error message, not the entire message. +styleWarning :: AnsiDoc -> AnsiDoc +styleWarning = yellow +-- | Style an 'AnsiDoc' in a way to emphasize that it is a particularly good +-- thing. +styleGood :: AnsiDoc -> AnsiDoc +styleGood = green + +-- | Style an 'AnsiDoc' as a shell command, i.e. when suggesting something +-- to the user that should be typed in directly as written. +styleShell :: AnsiDoc -> AnsiDoc +styleShell = magenta + +-- | Style an 'AnsiDoc' as a filename. See 'styleDir' for directories. +styleFile :: AnsiDoc -> AnsiDoc +styleFile = bold . white + +-- | Style an 'AsciDoc' as a URL. For now using the same style as files. +styleUrl :: AnsiDoc -> AnsiDoc +styleUrl = styleFile + +-- | Style an 'AnsiDoc' as a directory name. See 'styleFile' for files. +styleDir :: AnsiDoc -> AnsiDoc +styleDir = bold . blue + +-- | Style an 'AnsiDoc' in a way that emphasizes that it is related to +-- a current thing. For example, could be used when talking about the +-- current package we're processing when outputting the name of it. +styleCurrent :: AnsiDoc -> AnsiDoc +styleCurrent = yellow + +-- TODO: figure out how to describe this +styleTarget :: AnsiDoc -> AnsiDoc +styleTarget = cyan + +-- | Style an 'AnsiDoc' as a module name +styleModule :: AnsiDoc -> AnsiDoc +styleModule = magenta -- TODO: what color should this be? + instance Display PackageName where display = fromString . packageNameString @@ -129,18 +204,24 @@ display = fromString . versionString instance Display (Path b File) where - display = bold . white . fromString . toFilePath + display = styleFile . fromString . toFilePath instance Display (Path b Dir) where - display = bold . blue . fromString . toFilePath + display = styleDir . fromString . toFilePath instance Display (PackageName, NamedComponent) where display = cyan . fromString . T.unpack . renderPkgComponent -- Display milliseconds. displayMilliseconds :: Clock.TimeSpec -> AnsiDoc -displayMilliseconds t = goodGreen $ +displayMilliseconds t = green $ (fromString . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> "ms" +-- | Display a bulleted list of 'AnsiDoc'. bulletedList :: [AnsiDoc] -> AnsiDoc -bulletedList = mconcat . intersperse line . map ("*" <+>) +bulletedList = mconcat . intersperse line . map (("*" <+>) . align) + +-- | Display a bulleted list of 'AnsiDoc' with a blank line between +-- each. +spacedBulletedList :: [AnsiDoc] -> AnsiDoc +spacedBulletedList = mconcat . intersperse (line <> line) . map (("*" <+>) . align) diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -18,32 +20,26 @@ , munlockFile ) where -import Control.Monad hiding (forM) -import Control.Monad.Logger -import Control.Exception.Lifted as EL -import Control.Monad.IO.Class -import Control.Monad.Trans.Control -import Data.IORef -import Data.Traversable +import Stack.Prelude import Path import Path.IO import Stack.Config import qualified Stack.Docker as Docker import qualified Stack.Nix as Nix import Stack.Setup -import Stack.Types.Compiler (CompilerVersion) +import Stack.Types.Compiler (CompilerVersion, CVType (..)) import Stack.Types.Config -import Stack.Types.StackT +import Stack.Types.Runner import System.Environment (getEnvironment) import System.IO import System.FileLock +-- FIXME it seems wrong that we call lcLoadBuildConfig multiple times loadCompilerVersion :: GlobalOpts - -> LoadConfig (StackT () IO) - -> IO CompilerVersion + -> LoadConfig + -> IO (CompilerVersion 'CVWanted) loadCompilerVersion go lc = do - bconfig <- runStackTGlobal () go $ - lcLoadBuildConfig lc (globalCompiler go) + bconfig <- lcLoadBuildConfig lc (globalCompiler go) return $ view wantedCompilerVersionL bconfig -- | Enforce mutual exclusion of every action running via this @@ -53,7 +49,7 @@ -- stack uses locks per-snapshot. In the future, stack may refine -- this to an even more fine-grain locking approach. -- -withUserFileLock :: (MonadBaseControl IO m, MonadIO m) +withUserFileLock :: MonadUnliftIO m => GlobalOpts -> Path Abs Dir -> (Maybe FileLock -> m a) @@ -68,19 +64,19 @@ ensureDir dir -- Just in case of asynchronous exceptions, we need to be careful -- when using tryLockFile here: - EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive) - (maybe (return ()) (liftIO . unlockFile)) - (\fstTry -> + bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive) + (maybe (return ()) (liftIO . unlockFile)) + (\fstTry -> case fstTry of - Just lk -> EL.finally (act $ Just lk) (liftIO $ unlockFile lk) + Just lk -> finally (act $ Just lk) (liftIO $ unlockFile lk) Nothing -> do let chatter = globalLogLevel go /= LevelOther "silent" when chatter $ liftIO $ hPutStrLn stderr $ "Failed to grab lock ("++show pth++ "); other stack instance running. Waiting..." - EL.bracket (liftIO $ lockFile (toFilePath pth) Exclusive) - (liftIO . unlockFile) - (\lk -> do + bracket (liftIO $ lockFile (toFilePath pth) Exclusive) + (liftIO . unlockFile) + (\lk -> do when chatter $ liftIO $ hPutStrLn stderr "Lock acquired, proceeding." act $ Just lk)) @@ -88,16 +84,15 @@ withConfigAndLock :: GlobalOpts - -> StackT Config IO () + -> RIO Config () -> IO () -withConfigAndLock go@GlobalOpts{..} inner = do - lc <- loadConfigWithOpts go +withConfigAndLock go@GlobalOpts{..} inner = loadConfigWithOpts go $ \lc -> do withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> - runStackTGlobal (lcConfig lc) go $ + runRIO (lcConfig lc) $ Docker.reexecWithOptionalContainer (lcProjectRoot lc) Nothing - (runStackTGlobal (lcConfig lc) go inner) + (runRIO (lcConfig lc) inner) Nothing (Just $ munlockFile lk) @@ -105,22 +100,22 @@ -- loaded due to $PWD. withGlobalConfigAndLock :: GlobalOpts - -> StackT Config IO () + -> RIO Config () -> IO () -withGlobalConfigAndLock go@GlobalOpts{..} inner = do - lc <- runStackTGlobal () go $ +withGlobalConfigAndLock go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do + lc <- runRIO runner $ loadConfigMaybeProject globalConfigMonoid Nothing LCSNoProject withUserFileLock go (configStackRoot $ lcConfig lc) $ \_lk -> - runStackTGlobal (lcConfig lc) go inner + runRIO (lcConfig lc) inner -- For now the non-locking version just unlocks immediately. -- That is, there's still a serialization point. withBuildConfig :: GlobalOpts - -> StackT EnvConfig IO () + -> RIO EnvConfig () -> IO () withBuildConfig go inner = withBuildConfigAndLock go (\lk -> do munlockFile lk @@ -128,14 +123,16 @@ withBuildConfigAndLock :: GlobalOpts - -> (Maybe FileLock -> StackT EnvConfig IO ()) + -> (Maybe FileLock -> RIO EnvConfig ()) -> IO () withBuildConfigAndLock go inner = withBuildConfigExt False go Nothing inner Nothing +-- | See issue #2010 for why this exists. Currently just used for the +-- specific case of "stack clean --full". withBuildConfigAndLockNoDocker :: GlobalOpts - -> (Maybe FileLock -> StackT EnvConfig IO ()) + -> (Maybe FileLock -> RIO EnvConfig ()) -> IO () withBuildConfigAndLockNoDocker go inner = withBuildConfigExt True go Nothing inner Nothing @@ -143,23 +140,21 @@ withBuildConfigExt :: Bool -> GlobalOpts - -> Maybe (StackT Config IO ()) + -> Maybe (RIO Config ()) -- ^ Action to perform before the build. This will be run on the host -- OS even if Docker is enabled for builds. The build config is not -- available in this action, since that would require build tools to be -- installed on the host OS. - -> (Maybe FileLock -> StackT EnvConfig IO ()) + -> (Maybe FileLock -> RIO EnvConfig ()) -- ^ Action that uses the build config. If Docker is enabled for builds, -- this will be run in a Docker container. - -> Maybe (StackT Config IO ()) + -> Maybe (RIO Config ()) -- ^ Action to perform after the build. This will be run on the host -- OS even if Docker is enabled for builds. The build config is not -- available in this action, since that would require build tools to be -- installed on the host OS. -> IO () -withBuildConfigExt skipDocker go@GlobalOpts{..} mbefore inner mafter = do - lc <- loadConfigWithOpts go - +withBuildConfigExt skipDocker go@GlobalOpts{..} mbefore inner mafter = loadConfigWithOpts go $ \lc -> do withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk0 -> do -- A local bit of state for communication between callbacks: curLk <- newIORef lk0 @@ -172,32 +167,25 @@ withUserFileLock go dir $ \lk2 -> do liftIO $ writeIORef curLk lk2 liftIO $ munlockFile lk - $logDebug "Starting to execute command inside EnvConfig" + logDebug "Starting to execute command inside EnvConfig" inner lk2 let inner'' lk = do - bconfig <- runStackTGlobal () go $ - lcLoadBuildConfig lc globalCompiler - envConfig <- - runStackTGlobal - bconfig go - (setupEnv Nothing) - runStackTGlobal - envConfig - go - (inner' lk) + bconfig <- lcLoadBuildConfig lc globalCompiler + envConfig <- runRIO bconfig (setupEnv Nothing) + runRIO envConfig (inner' lk) let getCompilerVersion = loadCompilerVersion go lc if skipDocker - then runStackTGlobal (lcConfig lc) go $ do + then runRIO (lcConfig lc) $ do forM_ mbefore id - liftIO $ inner'' lk0 + Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (inner'' lk0) forM_ mafter id - else runStackTGlobal (lcConfig lc) go $ + else runRIO (lcConfig lc) $ Docker.reexecWithOptionalContainer (lcProjectRoot lc) mbefore - (runStackTGlobal (lcConfig lc) go $ + (runRIO (lcConfig lc) $ Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (inner'' lk0)) mafter (Just $ liftIO $ @@ -206,10 +194,13 @@ -- | Load the configuration. Convenience function used -- throughout this module. -loadConfigWithOpts :: GlobalOpts -> IO (LoadConfig (StackT () IO)) -loadConfigWithOpts go@GlobalOpts{..} = do +loadConfigWithOpts + :: GlobalOpts + -> (LoadConfig -> IO a) + -> IO a +loadConfigWithOpts go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do mstackYaml <- forM globalStackYaml resolveFile' - runStackTGlobal () go $ do + runRIO runner $ do lc <- loadConfig globalConfigMonoid globalResolver mstackYaml -- If we have been relaunched in a Docker container, perform in-container initialization -- (switch UID, etc.). We do this after first loading the configuration since it must @@ -217,21 +208,30 @@ case globalDockerEntrypoint of Just de -> Docker.entrypoint (lcConfig lc) de Nothing -> return () - return lc + liftIO $ inner lc +withRunnerGlobal :: GlobalOpts -> (Runner -> IO a) -> IO a +withRunnerGlobal GlobalOpts{..} = withRunner + globalLogLevel + globalTimeInLog + globalTerminal + globalColorWhen + globalTermWidth + (isJust globalReExecVersion) + withMiniConfigAndLock :: GlobalOpts - -> StackT MiniConfig IO () + -> RIO MiniConfig () -> IO () -withMiniConfigAndLock go@GlobalOpts{..} inner = do +withMiniConfigAndLock go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do miniConfig <- - runStackTGlobal () go $ + runRIO runner $ (loadMiniConfig . lcConfig) <$> loadConfigMaybeProject globalConfigMonoid globalResolver LCSNoProject - runStackTGlobal miniConfig go inner + runRIO miniConfig inner -- | Unlock a lock file, if the value is Just munlockFile :: MonadIO m => Maybe FileLock -> m () diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -1,9 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies #-} -- Create a source distribution tarball @@ -19,59 +18,52 @@ import qualified Codec.Compression.GZip as GZip import Control.Applicative import Control.Concurrent.Execute (ActionContext(..)) -import Control.Monad (unless, void, liftM, filterM, foldM, when) -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Logger +import Stack.Prelude import Control.Monad.Reader.Class (local) -import Control.Monad.Trans.Control (liftBaseWith) -import Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Char (toLower) -import Data.Data (Data, Typeable, cast, gmapT) -import Data.Either (partitionEithers) -import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Data (cast) import Data.List import Data.List.Extra (nubOrd) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, catMaybes) -import Data.Monoid ((<>)) import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE import Data.Time.Clock.POSIX import Distribution.Package (Dependency (..)) import qualified Distribution.PackageDescription as Cabal import qualified Distribution.PackageDescription.Check as Check +import qualified Distribution.PackageDescription.Parse as Cabal import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) -import Distribution.Text (display) -import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion) -import Distribution.Version.Extra +import qualified Distribution.Types.UnqualComponentName as Cabal +import qualified Distribution.Text as Cabal +import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion, hasUpperBound, hasLowerBound) import Lens.Micro (set) import Path -import Path.IO hiding (getModificationTime, getPermissions) -import Prelude -- Fix redundant import warnings +import Path.IO hiding (getModificationTime, getPermissions, withSystemTempDir) import Stack.Build (mkBaseConfigOpts, build) import Stack.Build.Execute import Stack.Build.Installed -import Stack.Build.Source (loadSourceMap, getDefaultPackageConfig) -import Stack.Build.Target -import Stack.Config (resolvePackageEntry, removePathFromPackageEntry) +import Stack.Build.Source (loadSourceMap) +import Stack.Build.Target hiding (PackageType (..)) +import Stack.PackageLocation (resolveMultiPackageLocation) +import Stack.PrettyPrint import Stack.Constants import Stack.Package import Stack.Types.Build +import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT -import Stack.Types.StringError +import Stack.Types.Runner import Stack.Types.Version import System.Directory (getModificationTime, getPermissions) import qualified System.FilePath as FP @@ -112,10 +104,10 @@ -- tarball is not written to the disk and instead yielded as a lazy -- bytestring. getSDistTarball - :: (StackM env m, HasEnvConfig env) + :: HasEnvConfig env => Maybe PvpBounds -- ^ Override Config value -> Path Abs Dir -- ^ Path to local package - -> m (FilePath, L.ByteString, Maybe (PackageIdentifier, L.ByteString)) + -> RIO env (FilePath, L.ByteString, Maybe (PackageIdentifier, L.ByteString)) -- ^ Filename, tarball contents, and option cabal file revision to upload getSDistTarball mpvpBounds pkgDir = do config <- view configL @@ -123,10 +115,10 @@ tweakCabal = pvpBounds /= PvpBoundsNone pkgFp = toFilePath pkgDir lp <- readLocalPackage pkgDir - $logInfo $ "Getting file list for " <> T.pack pkgFp + logInfo $ "Getting file list for " <> T.pack pkgFp (fileList, cabalfp) <- getSDistFileList lp - $logInfo $ "Building sdist tarball for " <> T.pack pkgFp - files <- normalizeTarballPaths (lines fileList) + logInfo $ "Building sdist tarball for " <> T.pack pkgFp + files <- normalizeTarballPaths (map (T.unpack . stripCR . T.pack) (lines fileList)) -- We're going to loop below and eventually find the cabal -- file. When we do, we'll upload this reference, if the @@ -151,13 +143,13 @@ -- This is a cabal file, we're going to tweak it, but only -- tweak it as a revision. | tweakCabal && isCabalFp fp && asRevision = do - lbsIdent <- getCabalLbs pvpBounds (Just 1) $ toFilePath cabalfp + lbsIdent <- getCabalLbs pvpBounds (Just 1) cabalfp liftIO (writeIORef cabalFileRevisionRef (Just lbsIdent)) packWith packFileEntry False fp -- Same, except we'll include the cabal file in the -- original tarball upload. | tweakCabal && isCabalFp fp = do - (_ident, lbs) <- getCabalLbs pvpBounds Nothing $ toFilePath cabalfp + (_ident, lbs) <- getCabalLbs pvpBounds Nothing cabalfp currTime <- liftIO getPOSIXTime -- Seconds from UNIX epoch tp <- liftIO $ tarPath False fp return $ (Tar.fileEntry tp lbs) { Tar.entryTime = floor currTime } @@ -171,14 +163,15 @@ return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)), mcabalFileRevision) -- | Get the PVP bounds-enabled version of the given cabal file -getCabalLbs :: (StackM env m, HasEnvConfig env) +getCabalLbs :: HasEnvConfig env => PvpBoundsType -> Maybe Int -- ^ optional revision - -> FilePath - -> m (PackageIdentifier, L.ByteString) -getCabalLbs pvpBounds mrev fp = do - path <- liftIO $ resolveFile' fp - (_warnings, gpd) <- readPackageUnresolved path + -> Path Abs File -- ^ cabal file + -> RIO env (PackageIdentifier, L.ByteString) +getCabalLbs pvpBounds mrev cabalfp = do + (gpd, cabalfp') <- readPackageUnresolvedDir (parent cabalfp) False + unless (cabalfp == cabalfp') + $ error $ "getCabalLbs: cabalfp /= cabalfp': " ++ show (cabalfp, cabalfp') (_, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI menv <- getMinimalEnvOverride (installedMap, _, _, _) <- getInstalled menv GetInstalledOpts @@ -187,7 +180,10 @@ , getInstalledSymbols = False } sourceMap - let gpd' = gtraverseT (addBounds sourceMap installedMap) gpd + let internalPackages = Set.fromList $ + gpdPackageName gpd : + map (fromCabalPackageName . Cabal.unqualComponentNameToPackageName . fst) (Cabal.condSubLibraries gpd) + gpd' = gtraverseT (addBounds internalPackages sourceMap installedMap) gpd gpd'' = case mrev of Nothing -> gpd' @@ -201,25 +197,74 @@ $ Cabal.packageDescription gpd' } } - ident <- parsePackageIdentifierFromString $ display $ Cabal.package $ Cabal.packageDescription gpd'' + ident <- parsePackageIdentifierFromString $ Cabal.display $ Cabal.package $ Cabal.packageDescription gpd'' + -- Sanity rendering and reparsing the input, to ensure there are no + -- cabal bugs, since there have been bugs here before, and currently + -- are at the time of writing: + -- + -- https://github.com/haskell/cabal/issues/1202 + -- https://github.com/haskell/cabal/issues/2353 + -- https://github.com/haskell/cabal/issues/4863 (current issue) + let roundtripErrs = + [ flow "Bug detected in Cabal library. ((parse . render . parse) === id) does not hold for the cabal file at" + <+> display cabalfp + , "" + ] + case Cabal.parseGenericPackageDescription (showGenericPackageDescription gpd) of + Cabal.ParseOk _ roundtripped + | roundtripped == gpd -> return () + | otherwise -> do + prettyWarn $ vsep $ roundtripErrs ++ + [ "This seems to be fixed in development versions of Cabal, but at time of writing, the fix is not in any released versions." + , "" + , "Please see this GitHub issue for status:" <+> styleUrl "https://github.com/commercialhaskell/stack/issues/3549" + , "" + , fillSep + [ flow "If the issue is closed as resolved, then you may be able to fix this by upgrading to a newer version of stack via" + , styleShell "stack upgrade" + , flow "for latest stable version or" + , styleShell "stack upgrade --git" + , flow "for the latest development version." + ] + , "" + , fillSep + [ flow "If the issue is fixed, but updating doesn't solve the problem, please check if there are similar open issues, and if not, report a new issue to the stack issue tracker, at" + , styleUrl "https://github.com/commercialhaskell/stack/issues/new" + ] + , "" + , flow "If the issue is not fixed, feel free to leave a comment on it indicating that you would like it to be fixed." + , "" + ] + Cabal.ParseFailed err -> do + prettyWarn $ vsep $ roundtripErrs ++ + [ flow "In particular, parsing the rendered cabal file is yielding a parse error. Please check if there are already issues tracking this, and if not, please report new issues to the stack and cabal issue trackers, via" + , bulletedList + [ styleUrl "https://github.com/commercialhaskell/stack/issues/new" + , styleUrl "https://github.com/haskell/cabal/issues/new" + ] + , flow $ "The parse error is: " ++ show err + , "" + ] return ( ident , TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd'' ) where - addBounds :: SourceMap -> InstalledMap -> Dependency -> Dependency - addBounds sourceMap installedMap dep@(Dependency cname range) = - case lookupVersion (fromCabalPackageName cname) of - Nothing -> dep - Just version -> Dependency cname $ simplifyVersionRange - $ (if toAddUpper && not (hasUpper range) then addUpper version else id) - $ (if toAddLower && not (hasLower range) then addLower version else id) - range + addBounds :: Set PackageName -> SourceMap -> InstalledMap -> Dependency -> Dependency + addBounds internalPackages sourceMap installedMap dep@(Dependency cname range) = + if name `Set.member` internalPackages + then dep + else case foundVersion of + Nothing -> dep + Just version -> Dependency cname $ simplifyVersionRange + $ (if toAddUpper && not (hasUpperBound range) then addUpper version else id) + $ (if toAddLower && not (hasLowerBound range) then addLower version else id) + range where - lookupVersion name = + name = fromCabalPackageName cname + foundVersion = case Map.lookup name sourceMap of - Just (PSLocal lp) -> Just $ packageVersion $ lpPackage lp - Just (PSUpstream version _ _ _ _) -> Just version + Just ps -> Just (piiVersion ps) Nothing -> case Map.lookup name installedMap of Just (_, installed) -> Just (installedVersion installed) @@ -247,12 +292,10 @@ -- | Read in a 'LocalPackage' config. This makes some default decisions -- about 'LocalPackage' fields that might not be appropriate for other -- use-cases. -readLocalPackage :: (StackM env m, HasEnvConfig env) => Path Abs Dir -> m LocalPackage +readLocalPackage :: HasEnvConfig env => Path Abs Dir -> RIO env LocalPackage readLocalPackage pkgDir = do - cabalfp <- findOrGenerateCabalFile pkgDir config <- getDefaultPackageConfig - (warnings,package) <- readPackage config cabalfp - mapM_ (printCabalFileWarning cabalfp) warnings + (package, cabalfp) <- readPackageDir config pkgDir True return LocalPackage { lpPackage = package , lpWanted = False -- HACK: makes it so that sdist output goes to a log instead of a file. @@ -269,10 +312,11 @@ , lpFiles = Set.empty , lpComponents = Set.empty , lpUnbuildable = Set.empty + , lpLocation = PLFilePath $ toFilePath pkgDir } -- | Returns a newline-separate list of paths, and the absolute path to the .cabal file. -getSDistFileList :: (StackM env m, HasEnvConfig env) => LocalPackage -> m (String, Path Abs File) +getSDistFileList :: HasEnvConfig env => LocalPackage -> RIO env (String, Path Abs File) getSDistFileList lp = withSystemTempDir (stackProgName <> "-sdist") $ \tmpdir -> do menv <- getMinimalEnvOverride @@ -280,21 +324,21 @@ let boptsCli = defaultBuildOptsCLI baseConfigOpts <- mkBaseConfigOpts boptsCli (locals, _) <- loadSourceMap NeedTargets boptsCli - runInBase <- liftBaseWith $ \run -> return (void . run) + run <- askRunInIO withExecuteEnv menv bopts boptsCli baseConfigOpts locals [] [] [] -- provide empty list of globals. This is a hack around custom Setup.hs files $ \ee -> - withSingleContext runInBase ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do + withSingleContext run ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do let outFile = toFilePath tmpdir FP. "source-files-list" cabal KeepTHLoading ["sdist", "--list-sources", outFile] - contents <- liftIO (readFile outFile) - return (contents, cabalfp) + contents <- liftIO (S.readFile outFile) + return (T.unpack $ T.decodeUtf8With T.lenientDecode contents, cabalfp) where package = lpPackage lp ac = ActionContext Set.empty [] task = Task { taskProvides = PackageIdentifier (packageName package) (packageVersion package) - , taskType = TTLocal lp + , taskType = TTFiles lp Local , taskConfigOpts = TaskConfigOpts { tcoMissing = Set.empty , tcoOpts = \_ -> ConfigureOpts [] [] @@ -302,14 +346,16 @@ , taskPresent = Map.empty , taskAllInOne = True , taskCachePkgSrc = CacheSrcLocal (toFilePath (lpDir lp)) + , taskAnyMissing = True + , taskBuildTypeConfig = False } -normalizeTarballPaths :: (StackM env m) => [FilePath] -> m [FilePath] +normalizeTarballPaths :: HasRunner env => [FilePath] -> RIO env [FilePath] normalizeTarballPaths fps = do -- TODO: consider whether erroring out is better - otherwise the -- user might upload an incomplete tar? unless (null outsideDir) $ - $logWarn $ T.concat + logWarn $ T.concat [ "Warning: These files are outside of the package directory, and will be omitted from the tarball: " , T.pack (show outsideDir)] return (nubOrd files) @@ -337,10 +383,11 @@ -- and will throw an exception in case of critical errors. -- -- Note that we temporarily decompress the archive to analyze it. -checkSDistTarball :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) +checkSDistTarball + :: HasEnvConfig env => SDistOpts -- ^ The configuration of what to check -> Path Abs File -- ^ Absolute path to tarball - -> m () + -> RIO env () checkSDistTarball opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do pkgDir <- (pkgDir' ) `liftM` (parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball) @@ -348,15 +395,16 @@ when (sdoptsBuildTarball opts) (buildExtractedTarball pkgDir) unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir) -checkPackageInExtractedTarball :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) +checkPackageInExtractedTarball + :: HasEnvConfig env => Path Abs Dir -- ^ Absolute path to tarball - -> m () + -> RIO env () checkPackageInExtractedTarball pkgDir = do - cabalfp <- findOrGenerateCabalFile pkgDir - name <- parsePackageNameFromFilePath cabalfp + (gpd, _cabalfp) <- readPackageUnresolvedDir pkgDir True + let name = gpdPackageName gpd config <- getDefaultPackageConfig - (gdesc, pkgDesc) <- readPackageDescriptionDir config pkgDir - $logInfo $ + (gdesc, PackageDescriptionPair pkgDesc _) <- readPackageDescriptionDir config pkgDir False + logInfo $ "Checking package '" <> packageNameText name <> "' for common mistakes" let pkgChecks = Check.checkPackage gdesc (Just pkgDesc) fileChecks <- liftIO $ Check.checkPackageFiles pkgDesc (toFilePath pkgDir) @@ -367,33 +415,25 @@ criticalIssue _ = False in partition criticalIssue checks unless (null warnings) $ - $logWarn $ "Package check reported the following warnings:\n" <> + logWarn $ "Package check reported the following warnings:\n" <> T.pack (intercalate "\n" . fmap show $ warnings) case NE.nonEmpty errors of Nothing -> return () Just ne -> throwM $ CheckException ne -buildExtractedTarball :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) => Path Abs Dir -> m () +buildExtractedTarball :: HasEnvConfig env => Path Abs Dir -> RIO env () buildExtractedTarball pkgDir = do projectRoot <- view projectRootL envConfig <- view envConfigL - menv <- getMinimalEnvOverride localPackageToBuild <- readLocalPackage pkgDir - let packageEntries = bcPackageEntries (envConfigBuildConfig envConfig) - getPaths entry = do - resolvedEntry <- resolvePackageEntry menv projectRoot entry - return $ fmap fst resolvedEntry - allPackagePaths <- fmap mconcat (mapM getPaths packageEntries) + let packageEntries = bcPackages (envConfigBuildConfig envConfig) + getPaths = resolveMultiPackageLocation projectRoot + allPackagePaths <- fmap (map fst . mconcat) (mapM getPaths packageEntries) -- We remove the path based on the name of the package let isPathToRemove path = do localPackage <- readLocalPackage path return $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild) - pathsToRemove <- filterM isPathToRemove allPackagePaths - let adjustPackageEntries entries path = do - adjustedPackageEntries <- mapM (removePathFromPackageEntry menv projectRoot path) entries - return (catMaybes adjustedPackageEntries) - entriesWithoutBuiltPackage <- foldM adjustPackageEntries packageEntries pathsToRemove - let newEntry = PackageEntry Nothing (PLFilePath (toFilePath pkgDir)) [] + pathsToKeep <- filterM (fmap not . isPathToRemove) allPackagePaths newPackagesRef <- liftIO (newIORef Nothing) let adjustEnvForBuild env = let updatedEnvConfig = envConfig @@ -402,7 +442,7 @@ } in set envConfigL updatedEnvConfig env updatePackageInBuildConfig buildConfig = buildConfig - { bcPackageEntries = newEntry : entriesWithoutBuiltPackage + { bcPackages = map (PLFilePath . toFilePath) $ pkgDir : pathsToKeep , bcConfig = (bcConfig buildConfig) { configBuild = defaultBuildOpts { boptsTests = True @@ -414,20 +454,21 @@ -- | Version of 'checkSDistTarball' that first saves lazy bytestring to -- temporary directory and then calls 'checkSDistTarball' on it. -checkSDistTarball' :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) +checkSDistTarball' + :: HasEnvConfig env => SDistOpts -> String -- ^ Tarball name -> L.ByteString -- ^ Tarball contents as a byte string - -> m () + -> RIO env () checkSDistTarball' opts name bytes = withSystemTempDir "stack" $ \tpath -> do npath <- (tpath ) `liftM` parseRelFile name liftIO $ L.writeFile (toFilePath npath) bytes checkSDistTarball opts npath -withTempTarGzContents :: (MonadIO m, MonadMask m) - => Path Abs File -- ^ Location of tarball - -> (Path Abs Dir -> m a) -- ^ Perform actions given dir with tarball contents - -> m a +withTempTarGzContents + :: Path Abs File -- ^ Location of tarball + -> (Path Abs Dir -> RIO env a) -- ^ Perform actions given dir with tarball contents + -> RIO env a withTempTarGzContents apath f = withSystemTempDir "stack" $ \tpath -> do archive <- liftIO $ L.readFile (toFilePath apath) liftIO . Tar.unpack (toFilePath tpath) . Tar.read . GZip.decompress $ archive @@ -456,3 +497,17 @@ getModTime path = do t <- getModificationTime path return . floor . utcTimeToPOSIXSeconds $ t + +getDefaultPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env) + => m PackageConfig +getDefaultPackageConfig = do + platform <- view platformL + compilerVersion <- view actualCompilerVersionL + return PackageConfig + { packageConfigEnableTests = False + , packageConfigEnableBenchmarks = False + , packageConfigFlags = mempty + , packageConfigGhcOptions = [] + , packageConfigCompilerVersion = compilerVersion + , packageConfigPlatform = platform + } diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -5,28 +6,16 @@ ( scriptCmd ) where -import Control.Exception (assert) -import Control.Exception.Safe (throwM) -import Control.Monad (unless, forM) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger -import Data.ByteString (ByteString) +import Stack.Prelude import qualified Data.ByteString.Char8 as S8 import qualified Data.Conduit.List as CL -import Data.Foldable (fold) import Data.List.Split (splitWhen) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as Set -import Data.Store.VersionTagged (versionedDecodeOrLoad) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import Path import Path.IO import qualified Stack.Build -import Stack.BuildPlan (loadBuildPlan) import Stack.Exec import Stack.GhcPkg (ghcPkgExeName) import Stack.Options.ScriptParser @@ -35,20 +24,18 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.PackageName -import Stack.Types.Resolver -import Stack.Types.StackT -import Stack.Types.StringError import System.FilePath (dropExtension, replaceExtension) import System.Process.Read -- | Run a Stack Script scriptCmd :: ScriptOpts -> GlobalOpts -> IO () scriptCmd opts go' = do + file <- resolveFile' $ soFile opts let go = go' { globalConfigMonoid = (globalConfigMonoid go') { configMonoidInstallGHC = First $ Just True } - , globalStackYaml = SYLNoConfig + , globalStackYaml = SYLNoConfig $ parent file } withBuildConfigAndLock go $ \lk -> do -- Some warnings in case the user somehow tries to set a @@ -57,24 +44,26 @@ -- interpreter mode, only error messages are shown. See: -- https://github.com/commercialhaskell/stack/issues/3007 case globalStackYaml go' of - SYLOverride fp -> $logError $ T.pack + SYLOverride fp -> logError $ T.pack $ "Ignoring override stack.yaml file for script command: " ++ fp SYLDefault -> return () - SYLNoConfig -> assert False (return ()) + SYLNoConfig _ -> assert False (return ()) config <- view configL menv <- liftIO $ configEnvOverride config defaultEnvSettings wc <- view $ actualCompilerVersionL.whichCompilerL + colorFlag <- appropriateGhcColorFlag - (targetsSet, coresSet) <- + targetsSet <- case soPackages opts of - [] -> + [] -> do -- Using the import parser - getPackagesFromImports (globalResolver go) (soFile opts) + moduleInfo <- view $ loadedSnapshotL.to toModuleInfo + getPackagesFromModuleInfo moduleInfo (soFile opts) packages -> do let targets = concatMap wordsComma packages targets' <- mapM parsePackageNameFromString targets - return (Set.fromList targets', Set.empty) + return $ Set.fromList targets' unless (Set.null targetsSet) $ do -- Optimization: use the relatively cheap ghc-pkg list @@ -90,30 +79,31 @@ $ S8.unpack $ S8.concat bss if Set.null $ Set.difference (Set.map packageNameString targetsSet) installed - then $logDebug "All packages already installed" + then logDebug "All packages already installed" else do - $logDebug "Missing packages, performing installation" + logDebug "Missing packages, performing installation" Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI { boptsCLITargets = map packageNameText $ Set.toList targetsSet } let ghcArgs = concat [ ["-hide-all-packages"] + , maybeToList colorFlag , map (\x -> "-package" ++ x) $ Set.toList $ Set.insert "base" - $ Set.map packageNameString (Set.union targetsSet coresSet) + $ Set.map packageNameString targetsSet , case soCompile opts of SEInterpret -> [] SECompile -> [] SEOptimize -> ["-O2"] + , map (\x -> "--ghc-arg=" ++ x) (soGhcOptions opts) ] munlockFile lk -- Unlock before transferring control away. case soCompile opts of SEInterpret -> exec menv ("run" ++ compilerExeName wc) - (ghcArgs ++ soFile opts : soArgs opts) + (ghcArgs ++ toFilePath file : soArgs opts) _ -> do - file <- resolveFile' $ soFile opts let dir = parent file -- use sinkProcessStdout to ensure a ProcessFailed -- exception is generated for better error messages @@ -121,7 +111,7 @@ (Just dir) menv (compilerExeName wc) - (ghcArgs ++ [soFile opts]) + (ghcArgs ++ [toFilePath file]) CL.sinkNull exec menv (toExeName $ toFilePath file) (soArgs opts) where @@ -142,19 +132,12 @@ isWindows = False #endif --- | Returns packages that need to be installed, and all of the core --- packages. Reason for the core packages: - --- Ideally we'd have the list of modules per core package listed in --- the build plan, but that doesn't exist yet. Next best would be to --- list the modules available at runtime, but that gets tricky with when we install GHC. Instead, we'll just list all core packages -getPackagesFromImports :: Maybe AbstractResolver - -> FilePath - -> StackT EnvConfig IO (Set PackageName, Set PackageName) -getPackagesFromImports Nothing _ = throwM NoResolverWhenUsingNoLocalConfig -getPackagesFromImports (Just (ARResolver (ResolverSnapshot name))) scriptFP = do +getPackagesFromModuleInfo + :: ModuleInfo + -> FilePath -- ^ script filename + -> RIO EnvConfig (Set PackageName) +getPackagesFromModuleInfo mi scriptFP = do (pns1, mns) <- liftIO $ parseImports <$> S8.readFile scriptFP - mi <- loadModuleInfo name pns2 <- if Set.null mns then return Set.empty @@ -173,14 +156,7 @@ ] Nothing -> return Set.empty return $ Set.unions pns `Set.difference` blacklist - return (Set.union pns1 pns2, modifyForWindows $ miCorePackages mi) - where - modifyForWindows - | isWindows = Set.insert $(mkPackageName "Win32") . Set.delete $(mkPackageName "unix") - | otherwise = id - -getPackagesFromImports (Just (ARResolver (ResolverCompiler _))) _ = return (Set.empty, Set.empty) -getPackagesFromImports (Just aresolver) _ = throwM $ InvalidResolverForNoLocalConfig $ show aresolver + return $ Set.union pns1 pns2 -- | The Stackage project introduced the concept of hidden packages, -- to deal with conflicting module names. However, this is a @@ -234,43 +210,28 @@ , $(mkPackageName "cryptohash-sha256") ] -toModuleInfo :: BuildPlan -> ModuleInfo -toModuleInfo bp = ModuleInfo - { miCorePackages = Map.keysSet $ siCorePackages $ bpSystemInfo bp - , miModules = - Map.unionsWith Set.union - $ map ((\(pn, mns) -> - Map.fromList - $ map (\mn -> (ModuleName $ encodeUtf8 mn, Set.singleton pn)) - $ Set.toList mns) . fmap (sdModules . ppDesc)) - $ filter (\(pn, pp) -> - not (pcHide $ ppConstraints pp) && - pn `Set.notMember` blacklist) - $ Map.toList (bpPackages bp) - } - --- | Where to store module info caches -moduleInfoCache :: SnapName -> StackT EnvConfig IO (Path Abs File) -moduleInfoCache name = do - root <- view stackRootL - platform <- platformGhcVerOnlyRelDir - name' <- parseRelDir $ T.unpack $ renderSnapName name - -- These probably can't vary at all based on platform, even in the - -- future, so it's safe to call this unnecessarily paranoid. - return (root $(mkRelDir "script") name' platform $(mkRelFile "module-info.cache")) - -loadModuleInfo :: SnapName -> StackT EnvConfig IO ModuleInfo -loadModuleInfo name = do - path <- moduleInfoCache name - $(versionedDecodeOrLoad moduleInfoVC) path $ toModuleInfo <$> loadBuildPlan name +toModuleInfo :: LoadedSnapshot -> ModuleInfo +toModuleInfo ls = + mconcat + $ map (\(pn, lpi) -> + ModuleInfo + $ Map.fromList + $ map (\mn -> (mn, Set.singleton pn)) + $ Set.toList + $ lpiExposedModules lpi) + $ filter (\(pn, lpi) -> + not (lpiHide lpi) && + pn `Set.notMember` blacklist) + $ Map.toList + $ Map.union (void <$> lsPackages ls) (void <$> lsGlobals ls) parseImports :: ByteString -> (Set PackageName, Set ModuleName) parseImports = - fold . mapMaybe (parseLine . stripCR) . S8.lines + fold . mapMaybe (parseLine . stripCR') . S8.lines where -- Remove any carriage return character present at the end, to -- support Windows-style line endings (CRLF) - stripCR bs + stripCR' bs | S8.null bs = bs | S8.last bs == '\r' = S8.init bs | otherwise = bs diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -- ghc < 7.10 {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} @@ -32,69 +34,54 @@ ) where import qualified Codec.Archive.Tar as Tar -import Control.Applicative -import Control.Concurrent.Async.Lifted (Concurrently(..)) -import Control.Exception.Safe (catchIO, tryAny) -import Control.Monad (liftM, when, join, void, unless, guard) -import Control.Monad.Catch -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger -import Control.Monad.Reader (MonadReader, ReaderT (..)) +import Control.Applicative (empty) import Control.Monad.State (get, put, modify) -import Control.Monad.Trans.Control -import "cryptonite" Crypto.Hash (SHA1(..)) +import "cryptonite" Crypto.Hash (SHA1(..), SHA256(..)) import Data.Aeson.Extended import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as LBS import Data.Char (isSpace) -import Data.Conduit (Conduit, (=$), await, yield, awaitForever, (.|)) +import Data.Conduit (Conduit, (=$), await, yield, awaitForever) import Data.Conduit.Lazy (lazyConsume) import Data.Conduit.Lift (evalStateC) import qualified Data.Conduit.List as CL import Data.Conduit.Zlib (ungzip) -import Data.Either -import Data.Foldable hiding (concatMap, or, maximum) +import Data.Foldable (maximumBy) import qualified Data.HashMap.Strict as HashMap -import Data.IORef import Data.IORef.RunOnce (runOnce) import Data.List hiding (concat, elem, maximumBy, any) -import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe -import Data.Monoid -import Data.Ord (comparing) -import Data.Set (Set) import qualified Data.Set as Set -import Data.String -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) -import Data.Typeable (Typeable) import qualified Data.Yaml as Yaml -import Distribution.System (OS (Linux), Arch (..), Platform (..)) +import Distribution.System (OS, Arch (..), Platform (..)) import qualified Distribution.System as Cabal import Distribution.Text (simpleParse) +import Distribution.Version (mkVersion') import Lens.Micro (set) import Network.HTTP.Simple (getResponseBody, httpLBS, withResponse, getResponseStatusCode) import Network.HTTP.Download import Path import Path.CheckInstall (warnInstallSearchPathIssues) import Path.Extra (toFilePathNoTrailingSep) -import Path.IO hiding (findExecutable) +import Path.IO hiding (findExecutable, withSystemTempDir) import qualified Paths_stack as Meta -import Prelude hiding (concat, elem, any) -- Fix AMP warning -import Safe (headMay, readMay) +import Prelude (getLine, putStr, putStrLn, until) import Stack.Build (build) import Stack.Config (loadConfig) -import Stack.Constants (distRelativeDir, stackProgName) +import Stack.Constants (stackProgName) +import Stack.Constants.Config (distRelativeDir) import Stack.Exec (defaultEnvSettings) import Stack.Fetch -import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath) +import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar) +import Stack.Prelude import Stack.PrettyPrint import Stack.Setup.Installed +import Stack.Snapshot (loadSnapshot) import Stack.Types.Build import Stack.Types.Compiler import Stack.Types.CompilerBuild @@ -102,12 +89,13 @@ import Stack.Types.Docker import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT -import Stack.Types.StringError +import Stack.Types.Runner import Stack.Types.Version import qualified System.Directory as D -import System.Environment (getExecutablePath) +import System.Environment (getExecutablePath, lookupEnv) import System.Exit (ExitCode (..), exitFailure) +import System.IO (hFlush, stdout) +import System.IO.Error (isPermissionError) import System.FilePath (searchPathSeparator) import qualified System.FilePath as FP import System.Process (rawSystem) @@ -117,7 +105,11 @@ import Text.Printf (printf) #if !WINDOWS -import System.Posix.Files (setFileMode) +import Bindings.Uname (uname, release) +import Data.List.Split (splitOn) +import Foreign.C (throwErrnoIfMinus1_, peekCString) +import Foreign.Marshal (alloca) +import System.Posix.Files (setFileMode) #endif -- | Default location of the stack-setup.yaml file @@ -129,7 +121,7 @@ { soptsInstallIfMissing :: !Bool , soptsUseSystem :: !Bool -- ^ Should we use a system compiler installation, if available? - , soptsWantedCompiler :: !CompilerVersion + , soptsWantedCompiler :: !(CompilerVersion 'CVWanted) , soptsCompilerCheck :: !VersionCheck , soptsStackYaml :: !(Maybe (Path Abs File)) -- ^ If we got the desired GHC version from that file @@ -155,7 +147,7 @@ deriving Show data SetupException = UnsupportedSetupCombo OS Arch | MissingDependencies [String] - | UnknownCompilerVersion Text CompilerVersion [CompilerVersion] + | UnknownCompilerVersion Text (CompilerVersion 'CVWanted) [CompilerVersion 'CVActual] | UnknownOSKey Text | GHCSanityCheckCompileFailed ReadProcessException (Path Abs File) | WantedMustBeGHC @@ -216,9 +208,9 @@ , "' option to specify a location"] -- | Modify the environment variables (like PATH) appropriately, possibly doing installation too -setupEnv :: (StackM env m, HasBuildConfig env, HasGHCVariant env) +setupEnv :: (HasBuildConfig env, HasGHCVariant env) => Maybe Text -- ^ Message to give user when necessary GHC is not available - -> m EnvConfig + -> RIO env EnvConfig setupEnv mResolveMissingGHC = do config <- view configL bconfig <- view buildConfigL @@ -257,15 +249,27 @@ <*> Concurrently (getCabalPkgVer menv wc) <*> Concurrently (getGlobalDB menv wc) - $logDebug "Resolving package entries" + logDebug "Resolving package entries" packagesRef <- liftIO $ newIORef Nothing bc <- view buildConfigL + + -- Set up a modified environment which includes the modified PATH + -- that GHC can be found on. This is needed for looking up global + -- package information in loadSnapshot. + let bcPath :: BuildConfig + bcPath = set envOverrideL (const (return menv)) bc + + ls <- runRIO bcPath $ loadSnapshot + (Just compilerVer) + (view projectRootL bc) + (bcSnapshotDef bc) let envConfig0 = EnvConfig { envConfigBuildConfig = bc , envConfigCabalVersion = cabalVer , envConfigCompilerVersion = compilerVer , envConfigCompilerBuild = compilerBuild , envConfigPackagesRef = packagesRef + , envConfigLoadedSnapshot = ls } -- extra installation bin directories @@ -287,6 +291,8 @@ utf8EnvVars <- getUtf8EnvVars menv compilerVer + mGhcRtsEnvVar <- liftIO $ lookupEnv "GHCRTS" + envRef <- liftIO $ newIORef Map.empty let getEnvOverride' es = do m <- readIORef envRef @@ -296,9 +302,7 @@ eo <- mkEnvOverride platform $ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath) $ (if esIncludeGhcPackagePath es - then Map.insert - (case wc of { Ghc -> "GHC_PACKAGE_PATH"; Ghcjs -> "GHCJS_PACKAGE_PATH" }) - (mkGPP (esIncludeLocals es)) + then Map.insert (ghcPkgPathEnvVar wc) (mkGPP (esIncludeLocals es)) else id) $ (if esStackExe es @@ -316,6 +320,11 @@ -> Map.insert "MSYSTEM" "MINGW64" _ -> id + -- See https://github.com/commercialhaskell/stack/issues/3444 + $ case (esKeepGhcRts es, mGhcRtsEnvVar) of + (True, Just ghcRts) -> Map.insert "GHCRTS" (T.pack ghcRts) + _ -> id + -- For reasoning and duplication, see: https://github.com/fpco/stack/issues/70 $ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePathNoTrailingSep deps) $ Map.insert "HASKELL_PACKAGE_SANDBOXES" @@ -345,6 +354,7 @@ , envConfigCompilerVersion = compilerVer , envConfigCompilerBuild = compilerBuild , envConfigPackagesRef = envConfigPackagesRef envConfig0 + , envConfigLoadedSnapshot = ls } -- | Add the include and lib paths to the given Config @@ -359,16 +369,16 @@ } -- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary -ensureCompiler :: (StackM env m, HasConfig env, HasGHCVariant env) +ensureCompiler :: (HasConfig env, HasGHCVariant env) => SetupOpts - -> m (Maybe ExtraDirs, CompilerBuild, Bool) + -> RIO env (Maybe ExtraDirs, CompilerBuild, Bool) ensureCompiler sopts = do let wc = whichCompiler (soptsWantedCompiler sopts) when (getGhcVersion (soptsWantedCompiler sopts) < $(mkVersion "7.8")) $ do - $logWarn "stack will almost certainly fail with GHC below version 7.8" - $logWarn "Valiantly attempting to run anyway, but I know this is doomed" - $logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648" - $logWarn "" + logWarn "stack will almost certainly fail with GHC below version 7.8" + logWarn "Valiantly attempting to run anyway, but I know this is doomed" + logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648" + logWarn "" -- Check the available GHCs menv0 <- getMinimalEnvOverride @@ -376,7 +386,7 @@ msystem <- if soptsUseSystem sopts then do - $logDebug "Getting system compiler version" + logDebug "Getting system compiler version" getSystemCompiler menv0 wc else return Nothing @@ -411,7 +421,7 @@ let tool = Tool (PackageIdentifier $(mkPackageName "msys2") version) Just <$> downloadAndInstallTool (configLocalPrograms config) si info tool (installMsys2Windows osKey) | otherwise -> do - $logWarn "Continuing despite missing tool: msys2" + logWarn "Continuing despite missing tool: msys2" return Nothing _ -> return Nothing @@ -497,8 +507,8 @@ forM_ (soptsUpgradeCabal sopts) $ \version -> do unless needLocal $ do - $logWarn "Trying to change a Cabal library on a GHC not installed by stack." - $logWarn "This may fail, caveat emptor!" + logWarn "Trying to change a Cabal library on a GHC not installed by stack." + logWarn "This may fail, caveat emptor!" upgradeCabal menv wc version case mtools of @@ -511,9 +521,7 @@ -- | Determine which GHC build to use depending on which shared libraries are available -- on the system. -getGhcBuild - :: (StackM env m, HasConfig env) - => EnvOverride -> m CompilerBuild +getGhcBuild :: HasConfig env => EnvOverride -> RIO env CompilerBuild getGhcBuild menv = do config <- view configL @@ -542,7 +550,7 @@ platform <- view platformL case platform of - Platform _ Linux -> do + Platform _ Cabal.Linux -> do -- Some systems don't have ldconfig in the PATH, so make sure to look in /sbin and /usr/sbin as well sbinEnv <- modifyEnvOverride menv $ Map.insert "PATH" $ @@ -551,12 +559,12 @@ eldconfigOut <- tryProcessStdout Nothing sbinEnv "ldconfig" ["-p"] egccErrOut <- tryProcessStderrStdout Nothing menv "gcc" ["-v"] let firstWords = case eldconfigOut of - Right ldconfigOut -> mapMaybe (headMay . T.words) $ + Right ldconfigOut -> mapMaybe (listToMaybe . T.words) $ T.lines $ T.decodeUtf8With T.lenientDecode ldconfigOut Left _ -> [] checkLib lib | libT `elem` firstWords = do - $logDebug ("Found shared library " <> libT <> " in 'ldconfig -p' output") + logDebug ("Found shared library " <> libT <> " in 'ldconfig -p' output") return True | otherwise = do #ifdef WINDOWS @@ -569,8 +577,8 @@ -- to scan for shared libs, but this works for our particular case. e <- doesFileExist ($(mkAbsDir "/usr/lib") lib) if e - then $logDebug ("Found shared library " <> libT <> " in /usr/lib") - else $logDebug ("Did not find shared library " <> libT) + then logDebug ("Found shared library " <> libT <> " in /usr/lib") + else logDebug ("Did not find shared library " <> libT) return e #endif where @@ -580,7 +588,7 @@ "--enable-default-pie" `elem` S8.words gccOutput || "Gentoo Hardened" `S8.isInfixOf` gccOutput where gccOutput = gccOut <> gccErr Left _ -> False - $logDebug $ if noPie + logDebug $ if noPie then "PIE disabled" else "PIE enabled" hastinfo5 <- checkLib $(mkRelFile "libtinfo.so.5") @@ -589,8 +597,8 @@ hasgmp5 <- checkLib $(mkRelFile "libgmp.so.10") hasgmp4 <- checkLib $(mkRelFile "libgmp.so.3") let libComponents = - if | hastinfo5 && hasgmp5 -> [] - | hastinfo6 && hasgmp5 -> ["tinfo6"] + if | hastinfo6 && hasgmp5 -> ["tinfo6"] + | hastinfo5 && hasgmp5 -> [] | hasncurses6 && hasgmp5 -> ["ncurses6"] | hasgmp4 && hastinfo5 -> ["gmp4"] | otherwise -> [] @@ -601,18 +609,48 @@ case libComponents ++ pieComponents of [] -> useBuild CompilerBuildStandard components -> useBuild (CompilerBuildSpecialized (intercalate "-" components)) +#if !WINDOWS + Platform _ Cabal.OpenBSD -> do + releaseStr <- mungeRelease <$> sysRelease + useBuild (CompilerBuildSpecialized releaseStr) +#endif _ -> useBuild CompilerBuildStandard useBuild CompilerBuildStandard = do - $logDebug "Using standard GHC build" + logDebug "Using standard GHC build" return CompilerBuildStandard useBuild (CompilerBuildSpecialized s) = do - $logDebug ("Using " <> T.pack s <> " GHC build") + logDebug ("Using " <> T.pack s <> " GHC build") return (CompilerBuildSpecialized s) +#if !WINDOWS +-- | Encode an OpenBSD version (like "6.1") into a valid argument for +-- CompilerBuildSpecialized, so "maj6-min1". Later version numbers are prefixed +-- with "r". +-- The result r must be such that "ghc-" ++ r is a valid package name, +-- as recognized by parsePackageNameFromString. +mungeRelease :: String -> String +mungeRelease = intercalate "-" . prefixMaj . splitOn "." + where + prefixFst pfx k (rev : revs) = (pfx ++ rev) : k revs + prefixFst _ _ [] = [] + prefixMaj = prefixFst "maj" prefixMin + prefixMin = prefixFst "min" (map ('r':)) + +sysRelease :: (MonadUnliftIO m, MonadLogger m) => m String +sysRelease = + handleIO (\e -> do + logWarn $ T.concat [ T.pack "Could not query OS version" + , T.pack $ show e + ] + return "") . + liftIO . + alloca $ \ ptr -> + do throwErrnoIfMinus1_ "uname" $ uname ptr + peekCString $ release ptr +#endif + -- | Ensure Docker container-compatible 'stack' executable is downloaded -ensureDockerStackExe - :: (StackM env m, HasConfig env) - => Platform -> m (Path Abs File) +ensureDockerStackExe :: HasConfig env => Platform -> RIO env (Path Abs File) ensureDockerStackExe containerPlatform = do config <- view configL containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone) @@ -622,60 +660,65 @@ let stackExePath = stackExeDir $(mkRelFile "stack") stackExeExists <- doesFileExist stackExePath unless stackExeExists $ do - $logInfo $ mconcat ["Downloading Docker-compatible ", T.pack stackProgName, " executable"] + logInfo $ mconcat ["Downloading Docker-compatible ", T.pack stackProgName, " executable"] sri <- downloadStackReleaseInfo Nothing Nothing (Just (versionString stackVersion)) - let platforms = preferredPlatforms (containerPlatform, PlatformVariantNone) - downloadStackExe platforms sri stackExeDir (const $ return ()) + platforms <- runReaderT preferredPlatforms (containerPlatform, PlatformVariantNone) + downloadStackExe platforms sri stackExeDir False (const $ return ()) return stackExePath -- | Install the newest version or a specific version of Cabal globally -upgradeCabal :: (StackM env m, HasConfig env, HasGHCVariant env) +upgradeCabal :: (HasConfig env, HasGHCVariant env) => EnvOverride -> WhichCompiler -> UpgradeTo - -> m () -upgradeCabal menv wc cabalVersion = do - $logInfo "Manipulating the global Cabal is only for debugging purposes" + -> RIO env () +upgradeCabal menv wc upgradeTo = do + logInfo "Manipulating the global Cabal is only for debugging purposes" let name = $(mkPackageName "Cabal") - rmap <- resolvePackages Nothing Map.empty (Set.singleton name) + rmap <- resolvePackages Nothing mempty (Set.singleton name) installed <- getCabalPkgVer menv wc - case cabalVersion of - Specific version -> do - if installed /= version then - doCabalInstall menv wc installed version + case upgradeTo of + Specific wantedVersion -> do + if installed /= wantedVersion then + doCabalInstall menv wc installed wantedVersion else - $logInfo $ T.concat ["No install necessary. Cabal " + logInfo $ T.concat ["No install necessary. Cabal " , T.pack $ versionString installed , " is already installed"] Latest -> case map rpIdent rmap of [] -> throwString "No Cabal library found in index, cannot upgrade" - [PackageIdentifier name' version] | name == name' -> do - if installed > version then - doCabalInstall menv wc installed version + [PackageIdentifier name' latestVersion] | name == name' -> do + if installed < latestVersion then + doCabalInstall menv wc installed latestVersion else - $logInfo $ "No upgrade necessary. Latest Cabal already installed" + logInfo $ T.concat + [ "No upgrade necessary: Cabal-" + , T.pack $ versionString latestVersion + , " is the same or newer than latest hackage version " + , T.pack $ versionString installed + ] x -> error $ "Unexpected results for resolvePackages: " ++ show x -- Configure and run the necessary commands for a cabal install -doCabalInstall :: (StackM env m, HasConfig env, HasGHCVariant env) +doCabalInstall :: (HasConfig env, HasGHCVariant env) => EnvOverride -> WhichCompiler -> Version -> Version - -> m () -doCabalInstall menv wc installed version = do + -> RIO env () +doCabalInstall menv wc installed wantedVersion = do withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> do - $logInfo $ T.concat + logInfo $ T.concat [ "Installing Cabal-" - , T.pack $ versionString version + , T.pack $ versionString wantedVersion , " to replace " , T.pack $ versionString installed ] let name = $(mkPackageName "Cabal") - ident = PackageIdentifier name version - m <- unpackPackageIdents tmpdir Nothing (Map.singleton ident Nothing) + ident = PackageIdentifier name wantedVersion + m <- unpackPackageIdents tmpdir Nothing [PackageIdentifierRevision ident CFILatest] compilerPath <- join $ findExecutable menv (compilerExeName wc) - versionDir <- parseRelDir $ versionString version + versionDir <- parseRelDir $ versionString wantedVersion let installRoot = toFilePath $ parent (parent compilerPath) $(mkRelDir "new-cabal") versionDir @@ -696,10 +739,14 @@ runCmd (Cmd (Just dir) setupExe menv args) Nothing runCmd (Cmd (Just dir) setupExe menv ["build"]) Nothing runCmd (Cmd (Just dir) setupExe menv ["install"]) Nothing - $logInfo "New Cabal library installed" + logInfo "New Cabal library installed" -- | Get the version of the system compiler, if available -getSystemCompiler :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> m (Maybe (CompilerVersion, Arch)) +getSystemCompiler + :: HasLogFunc env + => EnvOverride + -> WhichCompiler + -> RIO env (Maybe (CompilerVersion 'CVActual, Arch)) getSystemCompiler menv wc = do let exeName = case wc of Ghc -> "ghc" @@ -710,7 +757,7 @@ eres <- tryProcessStdout Nothing menv exeName ["--info"] let minfo = do Right bs <- Just eres - pairs_ <- readMay $ S8.unpack bs :: Maybe [(String, String)] + pairs_ <- readMaybe $ S8.unpack bs :: Maybe [(String, String)] version <- lookup "Project version" pairs_ >>= parseVersionFromString arch <- lookup "Target platform" pairs_ >>= simpleParse . takeWhile (/= '-') return (version, arch) @@ -725,9 +772,7 @@ else return Nothing -- | Download the most recent SetupInfo -getSetupInfo - :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasConfig env) - => String -> m SetupInfo +getSetupInfo :: HasConfig env => String -> RIO env SetupInfo getSetupInfo stackSetupYaml = do config <- view configL setupInfos <- @@ -766,7 +811,7 @@ goodPackage _ = Nothing getInstalledGhcjs :: [Tool] - -> (CompilerVersion -> Bool) + -> (CompilerVersion 'CVActual -> Bool) -> Maybe Tool getInstalledGhcjs installed goodVersion = if null available @@ -777,33 +822,33 @@ goodPackage (ToolGhcjs cv) = if goodVersion cv then Just cv else Nothing goodPackage _ = Nothing -downloadAndInstallTool :: StackMiniM env m +downloadAndInstallTool :: HasRunner env => Path Abs Dir -> SetupInfo -> DownloadInfo -> Tool - -> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> m ()) - -> m Tool + -> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> RIO env ()) + -> RIO env Tool downloadAndInstallTool programsDir si downloadInfo tool installer = do ensureDir programsDir (file, at) <- downloadFromInfo programsDir downloadInfo tool dir <- installDir programsDir tool tempDir <- tempInstallDir programsDir tool - ignoringAbsence (removeDirRecur tempDir) + liftIO $ ignoringAbsence (removeDirRecur tempDir) ensureDir tempDir unmarkInstalled programsDir tool installer si file at tempDir dir markInstalled programsDir tool - ignoringAbsence (removeDirRecur tempDir) + liftIO $ ignoringAbsence (removeDirRecur tempDir) return tool -downloadAndInstallCompiler :: (StackM env m, HasConfig env, HasGHCVariant env) +downloadAndInstallCompiler :: (HasConfig env, HasGHCVariant env) => CompilerBuild -> SetupInfo - -> CompilerVersion + -> CompilerVersion 'CVWanted -> VersionCheck -> Maybe String - -> m Tool + -> RIO env Tool downloadAndInstallCompiler ghcBuild si wanted@GhcVersion{} versionCheck mbindistURL = do ghcVariant <- view ghcVariantL (selectedVersion, downloadInfo) <- case mbindistURL of @@ -813,7 +858,12 @@ _ -> throwM RequireCustomGHCVariant case wanted of GhcVersion version -> - return (version, GHCDownloadInfo mempty mempty (DownloadInfo (T.pack bindistURL) Nothing Nothing)) + return (version, GHCDownloadInfo mempty mempty DownloadInfo + { downloadInfoUrl = T.pack bindistURL + , downloadInfoContentLength = Nothing + , downloadInfoSha1 = Nothing + , downloadInfoSha256 = Nothing + }) _ -> throwM WantedMustBeGHC _ -> do @@ -826,7 +876,7 @@ case configPlatform config of Platform _ Cabal.Windows -> installGHCWindows selectedVersion _ -> installGHCPosix selectedVersion downloadInfo - $logInfo $ + logInfo $ "Preparing to install GHC" <> (case ghcVariant of GHCStandard -> "" @@ -835,7 +885,7 @@ CompilerBuildStandard -> "" b -> " (" <> T.pack (compilerBuildName b) <> ")") <> " to an isolated location." - $logInfo "This will not interfere with any system-level installation." + logInfo "This will not interfere with any system-level installation." ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild) let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion downloadAndInstallTool (configLocalPrograms config) si (gdiDownloadInfo downloadInfo) tool installer @@ -848,16 +898,16 @@ (selectedVersion, downloadInfo) <- case Map.lookup "source" $ siGHCJSs si of Nothing -> throwM $ UnknownOSKey "source" Just pairs_ -> getWantedCompilerInfo "source" versionCheck wanted id pairs_ - $logInfo "Preparing to install GHCJS to an isolated location." - $logInfo "This will not interfere with any system-level installation." + logInfo "Preparing to install GHCJS to an isolated location." + logInfo "This will not interfere with any system-level installation." let tool = ToolGhcjs selectedVersion downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installGHCJS getWantedCompilerInfo :: (Ord k, MonadThrow m) => Text -> VersionCheck - -> CompilerVersion - -> (k -> CompilerVersion) + -> CompilerVersion 'CVWanted + -> (k -> CompilerVersion 'CVActual) -> Map k a -> m (k, a) getWantedCompilerInfo key versionCheck wanted toCV pairs_ = @@ -870,7 +920,7 @@ sortBy (flip (comparing fst)) $ filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs_) -getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadCatch m) +getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m) => CompilerBuild -> m Text getGhcKey ghcBuild = do ghcVariant <- view ghcVariantL @@ -896,8 +946,8 @@ Platform arch os -> throwM $ UnsupportedSetupCombo os arch downloadFromInfo - :: StackMiniM env m - => Path Abs Dir -> DownloadInfo -> Tool -> m (Path Abs File, ArchiveType) + :: HasRunner env + => Path Abs Dir -> DownloadInfo -> Tool -> RIO env (Path Abs File, ArchiveType) downloadFromInfo programsDir downloadInfo tool = do at <- case extension of @@ -914,14 +964,18 @@ chattyDownload (T.pack (toolString tool)) downloadInfo path return path (parseAbsFile -> Just path) -> do - let DownloadInfo{downloadInfoContentLength=contentLength, downloadInfoSha1=sha1} = + let DownloadInfo{downloadInfoContentLength=contentLength, downloadInfoSha1=sha1, + downloadInfoSha256=sha256} = downloadInfo when (isJust contentLength) $ - $logWarn ("`content-length` in not checked \n" <> + logWarn ("`content-length` in not checked \n" <> "and should not be specified when `url` is a file path") when (isJust sha1) $ - $logWarn ("`sha1` is not checked and \n" <> + logWarn ("`sha1` is not checked and \n" <> "should not be specified when `url` is a file path") + when (isJust sha256) $ + logWarn ("`sha256` is not checked and \n" <> + "should not be specified when `url` is a file path") return path _ -> throwString $ "Error: `url` must be either an HTTP URL or absolute file path: " ++ url @@ -942,7 +996,7 @@ | TarGz | SevenZ -installGHCPosix :: (StackM env m, HasConfig env) +installGHCPosix :: HasConfig env => Version -> GHCDownloadInfo -> SetupInfo @@ -950,12 +1004,12 @@ -> ArchiveType -> Path Abs Dir -> Path Abs Dir - -> m () + -> RIO env () installGHCPosix version downloadInfo _ archiveFile archiveType tempDir destDir = do platform <- view platformL menv0 <- getMinimalEnvOverride menv <- mkEnvOverride platform (removeHaskellEnvVars (unEnvOverride menv0)) - $logDebug $ "menv = " <> T.pack (show (unEnvOverride menv)) + logDebug $ "menv = " <> T.pack (show (unEnvOverride menv)) (zipTool', compOpt) <- case archiveType of TarXz -> return ("xz", 'J') @@ -973,9 +1027,9 @@ <*> (checkDependency "gmake" <|> checkDependency "make") <*> tarDep - $logDebug $ "ziptool: " <> T.pack zipTool - $logDebug $ "make: " <> T.pack makeTool - $logDebug $ "tar: " <> T.pack tarTool + logDebug $ "ziptool: " <> T.pack zipTool + logDebug $ "make: " <> T.pack makeTool + logDebug $ "tar: " <> T.pack tarTool dir <- liftM (tempDir ) $ @@ -988,42 +1042,42 @@ case result of Right _ -> return () Left ex -> do - $logError (T.pack (show (ex :: ReadProcessException))) - $prettyError $ + logError (T.pack (show (ex :: ReadProcessException))) + prettyError $ hang 2 ("Error encountered while" <+> step <+> "GHC with" <> line <> - shellMagenta (fromString (unwords (cmd : args))) <> line <> + styleShell (fromString (unwords (cmd : args))) <> line <> -- TODO: Figure out how to insert \ in the appropriate spots - -- hang 2 (shellMagenta (fillSep (fromString cmd : map fromString args))) <> line <> + -- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <> "run in " <> display wd) <> line <> line <> "The following directories may now contain files, but won't be used by stack:" <> line <> " -" <+> display tempDir <> line <> " -" <+> display destDir <> line liftIO exitFailure - $logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ tempDir, " ..."] - $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) + logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ tempDir, " ..."] + logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) runStep "unpacking" tempDir mempty tarTool [compOpt : "xf", toFilePath archiveFile] - $logSticky "Configuring GHC ..." + logSticky "Configuring GHC ..." runStep "configuring" dir (gdiConfigureEnv downloadInfo) (toFilePath $ dir $(mkRelFile "configure")) (("--prefix=" ++ toFilePath destDir) : map T.unpack (gdiConfigureOpts downloadInfo)) - $logSticky "Installing GHC ..." + logSticky "Installing GHC ..." runStep "installing" dir mempty makeTool ["install"] - $logStickyDone $ "Installed GHC." - $logDebug $ "GHC installed to " <> T.pack (toFilePath destDir) + logStickyDone $ "Installed GHC." + logDebug $ "GHC installed to " <> T.pack (toFilePath destDir) -installGHCJS :: (StackM env m, HasConfig env) +installGHCJS :: HasConfig env => SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir - -> m () + -> RIO env () installGHCJS si archiveFile archiveType _tempDir destDir = do platform <- view platformL menv0 <- getMinimalEnvOverride @@ -1031,7 +1085,7 @@ -- stack below. let removeLockVar = Map.delete "STACK_LOCK" menv <- mkEnvOverride platform (removeLockVar (removeHaskellEnvVars (unEnvOverride menv0))) - $logDebug $ "menv = " <> T.pack (show (unEnvOverride menv)) + logDebug $ "menv = " <> T.pack (show (unEnvOverride menv)) -- NOTE: this is a bit of a hack - instead of using the temp -- directory, leave the unpacked source tarball in the destination @@ -1058,20 +1112,20 @@ (zipTool, tarTool) <- checkDependencies $ (,) <$> checkDependency zipTool' <*> checkDependency "tar" - $logDebug $ "ziptool: " <> T.pack zipTool - $logDebug $ "tar: " <> T.pack tarTool + logDebug $ "ziptool: " <> T.pack zipTool + logDebug $ "tar: " <> T.pack tarTool return $ do - ignoringAbsence (removeDirRecur destDir) - ignoringAbsence (removeDirRecur unpackDir) + liftIO $ ignoringAbsence (removeDirRecur destDir) + liftIO $ ignoringAbsence (removeDirRecur unpackDir) readProcessNull (Just destDir) menv tarTool ["xf", toFilePath archiveFile] innerDir <- expectSingleUnpackedDir archiveFile destDir renameDir innerDir unpackDir - $logSticky $ T.concat ["Unpacking GHCJS into ", T.pack . toFilePath $ unpackDir, " ..."] - $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) + logSticky $ T.concat ["Unpacking GHCJS into ", T.pack . toFilePath $ unpackDir, " ..."] + logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) runUnpack - $logSticky "Setting up GHCJS build environment" + logSticky "Setting up GHCJS build environment" let stackYaml = unpackDir $(mkRelFile "stack.yaml") destBinDir = destDir $(mkRelDir "bin") ensureDir destBinDir @@ -1082,24 +1136,23 @@ -- earlier. mwindowsInstallDir <- case platform of Platform _ Cabal.Windows -> - liftM Just $ runInnerStackT envConfig' installationRootLocal + liftM Just $ runRIO envConfig' installationRootLocal _ -> return Nothing - $logSticky "Installing GHCJS (this will take a long time) ..." - runInnerStackT (set (buildOptsL.buildOptsInstallExesL) True $ - set (buildOptsL.buildOptsHaddockL) False envConfig') $ - build (\_ -> return ()) Nothing defaultBuildOptsCLI + logSticky "Installing GHCJS (this will take a long time) ..." + buildInGhcjsEnv envConfig' defaultBuildOptsCLI -- Copy over *.options files needed on windows. forM_ mwindowsInstallDir $ \dir -> do (_, files) <- listDir (dir $(mkRelDir "bin")) forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do let dest = destDir $(mkRelDir "bin") filename optionsFile - ignoringAbsence (removeFile dest) + liftIO $ ignoringAbsence (removeFile dest) copyFile optionsFile dest - $logStickyDone "Installed GHCJS." + logStickyDone "Installed GHCJS." -ensureGhcjsBooted :: (StackM env m, HasConfig env) - => EnvOverride -> CompilerVersion -> Bool -> [String] -> m () +ensureGhcjsBooted :: HasConfig env + => EnvOverride -> CompilerVersion 'CVActual -> Bool -> [String] + -> RIO env () ensureGhcjsBooted menv cv shouldBoot bootOpts = do eres <- try $ sinkProcessStdout Nothing menv "ghcjs" [] (return ()) case eres of @@ -1133,8 +1186,8 @@ bootGhcjs ghcjsVersion actualStackYaml destDir bootOpts Left err -> throwM err -bootGhcjs :: StackM env m - => Version -> Path Abs File -> Path Abs Dir -> [String] -> m () +bootGhcjs :: HasRunner env + => Version -> Path Abs File -> Path Abs Dir -> [String] -> RIO env () bootGhcjs ghcjsVersion stackYaml destDir bootOpts = do envConfig <- loadGhcjsEnvConfig stackYaml (destDir $(mkRelDir "bin")) menv <- liftIO $ configEnvOverride (view configL envConfig) defaultEnvSettings @@ -1142,24 +1195,24 @@ mcabal <- getCabalInstallVersion menv shouldInstallCabal <- case mcabal of Nothing -> do - $logInfo "No cabal-install binary found for use with GHCJS." + logInfo "No cabal-install binary found for use with GHCJS." return True Just v | v < $(mkVersion "1.22.4") -> do - $logInfo $ + logInfo $ "The cabal-install found on PATH is too old to be used for booting GHCJS (version " <> versionText v <> ")." return True | v >= $(mkVersion "1.23") -> do - $logWarn $ + logWarn $ "The cabal-install found on PATH is a version stack doesn't know about, version " <> versionText v <> ". This may or may not work.\n" <> "See this issue: https://github.com/ghcjs/ghcjs/issues/470" return False | ghcjsVersion >= $(mkVersion "0.2.0.20160413") && v >= $(mkVersion "1.22.8") -> do - $logWarn $ + logWarn $ "The cabal-install found on PATH, version " <> versionText v <> ", is >= 1.22.8.\n" <> @@ -1167,33 +1220,55 @@ "See this issue: https://github.com/ghcjs/ghcjs/issues/470" return True | otherwise -> return False - let envSettings = defaultEnvSettings { esIncludeGhcPackagePath = False } + let envSettings = EnvSettings + { esIncludeLocals = True + , esIncludeGhcPackagePath = False + , esStackExe = True + , esLocaleUtf8 = True + , esKeepGhcRts = False + } menv' <- liftIO $ configEnvOverride (view configL envConfig) envSettings - when shouldInstallCabal $ do - $logInfo "Building a local copy of cabal-install from source." - runInnerStackT envConfig $ - build (\_ -> return ()) - Nothing - defaultBuildOptsCLI { boptsCLITargets = ["cabal-install"] } - mcabal' <- getCabalInstallVersion menv' - case mcabal' of - Nothing -> - $logError $ - "Failed to get cabal-install version after installing it.\n" <> - "This shouldn't happen, because it gets built to the snapshot bin directory, which should be treated as being on the PATH." - Just v | v >= $(mkVersion "1.22.8") && v < $(mkVersion "1.23") -> - $logWarn $ - "Installed version of cabal-install is in a version range which may not work.\n" <> - "See this issue: https://github.com/ghcjs/ghcjs/issues/470\n" <> - "This version is specified by the stack.yaml file included in the ghcjs tarball.\n" - _ -> return () - $logSticky "Booting GHCJS (this will take a long time) ..." + shouldInstallAlex <- not <$> doesExecutableExist menv "alex" + shouldInstallHappy <- not <$> doesExecutableExist menv "happy" + let bootDepsToInstall = + [ "cabal-install" | shouldInstallCabal ] ++ + [ "alex" | shouldInstallAlex ] ++ + [ "happy" | shouldInstallHappy ] + when (not (null bootDepsToInstall)) $ do + logInfo $ "Building tools from source, needed for ghcjs-boot: " <> T.pack (show bootDepsToInstall) + buildInGhcjsEnv envConfig $ defaultBuildOptsCLI { boptsCLITargets = bootDepsToInstall } + let failedToFindErr = do + logError "This shouldn't happen, because it gets built to the snapshot bin directory, which should be treated as being on the PATH." + liftIO exitFailure + when shouldInstallCabal $ do + mcabal' <- getCabalInstallVersion menv' + case mcabal' of + Nothing -> do + logError "Failed to get cabal-install version after installing it." + failedToFindErr + Just v | v >= $(mkVersion "1.22.8") && v < $(mkVersion "1.23") -> + logWarn $ + "Installed version of cabal-install is in a version range which may not work.\n" <> + "See this issue: https://github.com/ghcjs/ghcjs/issues/470\n" <> + "This version is specified by the stack.yaml file included in the ghcjs tarball.\n" + _ -> return () + when shouldInstallAlex $ do + alexInstalled <- doesExecutableExist menv "alex" + when (not alexInstalled) $ do + logError "Failed to find 'alex' executable after installing it." + failedToFindErr + when shouldInstallHappy $ do + happyInstalled <- doesExecutableExist menv "happy" + when (not happyInstalled) $ do + logError "Failed to find 'happy' executable after installing it." + failedToFindErr + logSticky "Booting GHCJS (this will take a long time) ..." logProcessStderrStdout Nothing "ghcjs-boot" menv' bootOpts - $logStickyDone "GHCJS booted." + logStickyDone "GHCJS booted." -loadGhcjsEnvConfig :: StackM env m - => Path Abs File -> Path b t -> m EnvConfig -loadGhcjsEnvConfig stackYaml binPath = runInnerStackT () $ do +loadGhcjsEnvConfig :: HasRunner env + => Path Abs File -> Path b t -> RIO env EnvConfig +loadGhcjsEnvConfig stackYaml binPath = do lc <- loadConfig (mempty { configMonoidInstallGHC = First (Just True) @@ -1201,14 +1276,19 @@ }) Nothing (SYLOverride stackYaml) - bconfig <- lcLoadBuildConfig lc Nothing - runInnerStackT bconfig $ setupEnv Nothing + bconfig <- liftIO $ lcLoadBuildConfig lc Nothing + runRIO bconfig $ setupEnv Nothing -getCabalInstallVersion :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m) - => EnvOverride -> m (Maybe Version) +buildInGhcjsEnv :: (HasEnvConfig env, MonadIO m) => env -> BuildOptsCLI -> m () +buildInGhcjsEnv envConfig boptsCli = do + runRIO (set (buildOptsL.buildOptsInstallExesL) True $ + set (buildOptsL.buildOptsHaddockL) False envConfig) $ + build (\_ -> return ()) Nothing boptsCli + +getCabalInstallVersion :: HasLogFunc env => EnvOverride -> RIO env (Maybe Version) getCabalInstallVersion menv = do ebs <- tryProcessStdout Nothing menv "cabal" ["--numeric-version"] - case ebs of + liftIO $ case ebs of Left _ -> return Nothing Right bs -> Just <$> parseVersion (T.dropWhileEnd isSpace (T.decodeUtf8 bs)) @@ -1246,31 +1326,31 @@ Left _ -> y menv Right x' -> return $ Right x' -installGHCWindows :: (StackMiniM env m, HasConfig env) +installGHCWindows :: HasConfig env => Version -> SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir - -> m () + -> RIO env () installGHCWindows version si archiveFile archiveType _tempDir destDir = do tarComponent <- parseRelDir $ "ghc-" ++ versionString version withUnpackedTarball7z "GHC" si archiveFile archiveType (Just tarComponent) destDir - $logInfo $ "GHC installed to " <> T.pack (toFilePath destDir) + logInfo $ "GHC installed to " <> T.pack (toFilePath destDir) -installMsys2Windows :: (StackMiniM env m, HasConfig env) +installMsys2Windows :: HasConfig env => Text -- ^ OS Key -> SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir - -> m () + -> RIO env () installMsys2Windows osKey si archiveFile archiveType _tempDir destDir = do exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do - $logError $ T.pack $ + logError $ T.pack $ "Could not delete existing msys directory: " ++ toFilePath destDir throwM e @@ -1299,14 +1379,14 @@ -- | Unpack a compressed tarball using 7zip. Expects a single directory in -- the unpacked results, which is renamed to the destination directory. -withUnpackedTarball7z :: (StackMiniM env m, HasConfig env) +withUnpackedTarball7z :: HasConfig env => String -- ^ Name of tool, used in error messages -> SetupInfo -> Path Abs File -- ^ Path to archive file -> ArchiveType -> Maybe (Path Rel Dir) -- ^ Name of directory expected in archive. If Nothing, expects a single folder. -> Path Abs Dir -- ^ Destination directory. - -> m () + -> RIO env () withUnpackedTarball7z name si archiveFile archiveType msrcDir destDir = do suffix <- case archiveType of @@ -1315,26 +1395,19 @@ TarGz -> return ".gz" _ -> throwString $ name ++ " must be a tarball file" tarFile <- - case T.stripSuffix suffix $ T.pack $ toFilePath archiveFile of + case T.stripSuffix suffix $ T.pack $ toFilePath (filename archiveFile) of Nothing -> throwString $ "Invalid " ++ name ++ " filename: " ++ show archiveFile - Just x -> parseAbsFile $ T.unpack x + Just x -> parseRelFile $ T.unpack x run7z <- setup7z si let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp" ensureDir (parent destDir) - withTempDir (parent destDir) tmpName $ \tmpDir -> do - ignoringAbsence (removeDirRecur destDir) - run7z (parent archiveFile) archiveFile - run7z tmpDir tarFile + withRunInIO $ \run -> withTempDir (parent destDir) tmpName $ \tmpDir -> run $ do + liftIO $ ignoringAbsence (removeDirRecur destDir) + run7z tmpDir archiveFile + run7z tmpDir (tmpDir tarFile) absSrcDir <- case msrcDir of Just srcDir -> return $ tmpDir srcDir Nothing -> expectSingleUnpackedDir archiveFile tmpDir - removeFile tarFile `catchIO` \e -> - $logWarn (T.concat - [ "Exception when removing " - , T.pack $ toFilePath tarFile - , ": " - , T.pack $ show e - ]) renameDir absSrcDir destDir expectSingleUnpackedDir :: (MonadIO m, MonadThrow m) => Path Abs File -> Path Abs Dir -> m (Path Abs Dir) @@ -1347,9 +1420,9 @@ -- | Download 7z as necessary, and get a function for unpacking things. -- -- Returned function takes an unpack directory and archive. -setup7z :: (MonadIO n, MonadLogger n, StackMiniM env m, HasConfig env) +setup7z :: (HasConfig env, MonadIO m) => SetupInfo - -> m (Path Abs Dir -> Path Abs File -> n ()) + -> RIO env (Path Abs Dir -> Path Abs File -> m ()) setup7z si = do dir <- view $ configL.to configLocalPrograms ensureDir dir @@ -1359,7 +1432,7 @@ (Just sevenzDll, Just sevenzExe) -> do chattyDownload "7z.dll" sevenzDll dll chattyDownload "7z.exe" sevenzExe exe - return $ \outdir archive -> do + withRunInIO $ \run -> return $ \outdir archive -> liftIO $ run $ do let cmd = toFilePath exe args = [ "x" @@ -1367,61 +1440,66 @@ , "-y" , toFilePath archive ] - ec <- $withProcessTimeLog cmd args $ + ec <- withProcessTimeLog cmd args $ liftIO $ rawSystem cmd args when (ec /= ExitSuccess) $ liftIO $ throwM (ProblemWhileDecompressing archive) _ -> throwM SetupInfoMissingSevenz -chattyDownload :: StackMiniM env m +chattyDownload :: HasRunner env => Text -- ^ label - -> DownloadInfo -- ^ URL, content-length, and sha1 + -> DownloadInfo -- ^ URL, content-length, sha1, and sha256 -> Path Abs File -- ^ destination - -> m () + -> RIO env () chattyDownload label downloadInfo path = do let url = downloadInfoUrl downloadInfo req <- parseUrlThrow $ T.unpack url - $logSticky $ T.concat + logSticky $ T.concat [ "Preparing to download " , label , " ..." ] - $logDebug $ T.concat + logDebug $ T.concat [ "Downloading from " , url , " to " , T.pack $ toFilePath path , " ..." ] - hashChecks <- case downloadInfoSha1 downloadInfo of - Just sha1ByteString -> do - let sha1 = CheckHexDigestByteString sha1ByteString - $logDebug $ T.concat - [ "Will check against sha1 hash: " - , T.decodeUtf8With T.lenientDecode sha1ByteString - ] - return [HashCheck SHA1 sha1] - Nothing -> do - $logWarn $ T.concat - [ "No sha1 found in metadata," - , " download hash won't be checked." + hashChecks <- fmap catMaybes $ forM + [ ("sha1", HashCheck SHA1, downloadInfoSha1) + , ("sha256", HashCheck SHA256, downloadInfoSha256) + ] + $ \(name, constr, getter) -> + case getter downloadInfo of + Just bs -> do + logDebug $ T.concat + [ "Will check against " + , name + , " hash: " + , T.decodeUtf8With T.lenientDecode bs ] - return [] + return $ Just $ constr $ CheckHexDigestByteString bs + Nothing -> return Nothing + when (null hashChecks) $ logWarn $ T.concat + [ "No sha1 or sha256 found in metadata," + , " download hash won't be checked." + ] let dReq = DownloadRequest { drRequest = req , drHashChecks = hashChecks , drLengthCheck = mtotalSize , drRetryPolicy = drRetryPolicyDefault } - runInBase <- liftBaseWith $ \run -> return (void . run) - x <- verifiedDownload dReq path (chattyDownloadProgress runInBase) + run <- askRunInIO + x <- verifiedDownload dReq path (chattyDownloadProgress run) if x - then $logStickyDone ("Downloaded " <> label <> ".") - else $logStickyDone "Already downloaded." + then logStickyDone ("Downloaded " <> label <> ".") + else logStickyDone "Already downloaded." where mtotalSize = downloadInfoContentLength downloadInfo chattyDownloadProgress runInBase _ = do - _ <- liftIO $ runInBase $ $logSticky $ + _ <- liftIO $ runInBase $ logSticky $ label <> ": download has begun" CL.map (Sum . S.length) =$ chunksOverTime 1 @@ -1430,7 +1508,7 @@ go = evalStateC 0 $ awaitForever $ \(Sum size) -> do modify (+ size) totalSoFar <- get - liftIO $ runInBase $ $logSticky $ T.pack $ + liftIO $ runInBase $ logSticky $ T.pack $ case mtotalSize of Nothing -> chattyProgressNoTotal totalSoFar Just 0 -> chattyProgressNoTotal totalSoFar @@ -1496,25 +1574,25 @@ go -- | Perform a basic sanity check of GHC -sanityCheck :: (MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m) +sanityCheck :: HasLogFunc env => EnvOverride -> WhichCompiler - -> m () + -> RIO env () sanityCheck menv wc = withSystemTempDir "stack-sanity-check" $ \dir -> do let fp = toFilePath $ dir $(mkRelFile "Main.hs") - liftIO $ writeFile fp $ unlines + liftIO $ S.writeFile fp $ T.encodeUtf8 $ T.pack $ unlines [ "import Distribution.Simple" -- ensure Cabal library is present , "main = putStrLn \"Hello World\"" ] let exeName = compilerExeName wc - ghc <- join $ findExecutable menv exeName - $logDebug $ "Performing a sanity check on: " <> T.pack (toFilePath ghc) + ghc <- liftIO $ join $ findExecutable menv exeName + logDebug $ "Performing a sanity check on: " <> T.pack (toFilePath ghc) eres <- tryProcessStdout (Just dir) menv exeName [ fp , "-no-user-package-db" ] case eres of - Left e -> throwM $ GHCSanityCheckCompileFailed e ghc + Left e -> throwIO $ GHCSanityCheckCompileFailed e ghc Right _ -> return () -- TODO check that the output of running the command is correct -- Remove potentially confusing environment variables @@ -1526,13 +1604,16 @@ Map.delete "HASKELL_PACKAGE_SANDBOXES" . Map.delete "HASKELL_DIST_DIR" . -- https://github.com/commercialhaskell/stack/issues/1460 - Map.delete "DESTDIR" + Map.delete "DESTDIR" . + -- https://github.com/commercialhaskell/stack/issues/3444 + Map.delete "GHCRTS" -- | Get map of environment variables to set to change the GHC's encoding to UTF-8 getUtf8EnvVars - :: forall m env. - (MonadReader env m, HasPlatform env, MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m) - => EnvOverride -> CompilerVersion -> m (Map Text Text) + :: (HasLogFunc env, HasPlatform env) + => EnvOverride + -> CompilerVersion 'CVActual + -> RIO env (Map Text Text) getUtf8EnvVars menv compilerVer = if getGhcVersion compilerVer >= $(mkVersion "7.10.3") -- GHC_CHARENC supported by GHC >=7.10.3 @@ -1581,7 +1662,7 @@ mfallback = getFallbackLocale utf8Locales when (isNothing mfallback) - ($logWarn + (logWarn "Warning: unable to set locale to UTF-8 encoding; GHC may fail with 'invalid character'") let -- Get the new values of variables to adjust. @@ -1686,7 +1767,7 @@ then return $ StackReleaseInfo $ getResponseBody res else throwString $ "Could not get release information for Stack from: " ++ url -preferredPlatforms :: (MonadReader env m, HasPlatform env) +preferredPlatforms :: (MonadReader env m, HasPlatform env, MonadThrow m) => m [(Bool, String)] preferredPlatforms = do Platform arch' os' <- view platformL @@ -1696,13 +1777,13 @@ Cabal.Windows -> return (True, "windows") Cabal.OSX -> return (False, "osx") Cabal.FreeBSD -> return (False, "freebsd") - _ -> errorString $ "Binary upgrade not yet supported on OS: " ++ show os' + _ -> throwM $ stringException $ "Binary upgrade not yet supported on OS: " ++ show os' arch <- case arch' of I386 -> return "i386" X86_64 -> return "x86_64" Arm -> return "arm" - _ -> errorString $ "Binary upgrade not yet supported on arch: " ++ show arch' + _ -> throwM $ stringException $ "Binary upgrade not yet supported on arch: " ++ show arch' hasgmp4 <- return False -- FIXME import relevant code from Stack.Setup? checkLib $(mkRelFile "libgmp.so.3") let suffixes | hasgmp4 = ["-static", "-gmp4", ""] @@ -1710,19 +1791,20 @@ return $ map (\suffix -> (isWindows, concat [os, "-", arch, suffix])) suffixes downloadStackExe - :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env) + :: HasConfig env => [(Bool, String)] -- ^ acceptable platforms -> StackReleaseInfo -> Path Abs Dir -- ^ destination directory + -> Bool -- ^ perform PATH-aware checking, see #3232 -> (Path Abs File -> IO ()) -- ^ test the temp exe before renaming - -> m () -downloadStackExe platforms0 archiveInfo destDir testExe = do + -> RIO env () +downloadStackExe platforms0 archiveInfo destDir checkPath testExe = do (isWindows, archiveURL) <- let loop [] = throwString $ "Unable to find binary Stack archive for platforms: " ++ unwords (map snd platforms0) loop ((isWindows, p'):ps) = do let p = T.pack p' - $logInfo $ "Querying for archive location for platform: " <> p + logInfo $ "Querying for archive location for platform: " <> p case findArchive archiveInfo p of Just x -> return (isWindows, x) Nothing -> loop ps @@ -1738,7 +1820,7 @@ , destDir $(mkRelFile "stack.tmp") ) - $logInfo $ "Downloading from: " <> archiveURL + logInfo $ "Downloading from: " <> archiveURL liftIO $ do case () of @@ -1747,7 +1829,7 @@ | ".zip" `T.isSuffixOf` archiveURL -> error "FIXME: Handle zip files" | otherwise -> error $ "Unknown archive format for Stack archive: " ++ T.unpack archiveURL - $logInfo "Download complete, testing executable" + logInfo "Download complete, testing executable" platform <- view platformL @@ -1769,7 +1851,10 @@ destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir warnInstallSearchPathIssues destDir' ["stack"] - $logInfo $ T.pack $ "New stack executable available at " ++ toFilePath destFile + logInfo $ T.pack $ "New stack executable available at " ++ toFilePath destFile + + when checkPath $ performPathChecking destFile + `catchAny` \e -> logError (T.pack (show e)) where findArchive (StackReleaseInfo val) pattern = do @@ -1821,6 +1906,77 @@ let base = FP.dropExtension (FP.takeBaseName (T.unpack url)) FP. "stack" in if isWindows then base FP.<.> "exe" else base +-- | Ensure that the Stack executable download is in the same location +-- as the currently running executable. See: +-- https://github.com/commercialhaskell/stack/issues/3232 +performPathChecking + :: HasConfig env + => Path Abs File -- ^ location of the newly downloaded file + -> RIO env () +performPathChecking newFile = do + executablePath <- liftIO getExecutablePath + executablePath' <- parseAbsFile executablePath + unless (toFilePath newFile == executablePath) $ do + logInfo $ T.pack $ "Also copying stack executable to " ++ executablePath + tmpFile <- parseAbsFile $ executablePath ++ ".tmp" + eres <- tryIO $ do + liftIO $ copyFile newFile tmpFile +#if !WINDOWS + liftIO $ setFileMode (toFilePath tmpFile) 0o755 +#endif + liftIO $ renameFile tmpFile executablePath' + logInfo "Stack executable copied successfully!" + case eres of + Right () -> return () + Left e + | isPermissionError e -> do + logWarn $ T.pack $ "Permission error when trying to copy: " ++ show e + logWarn "Should I try to perform the file copy using sudo? This may fail" + toSudo <- prompt "Try using sudo? (y/n) " + when toSudo $ do + let run cmd args = do + ec <- withProcessTimeLog cmd args $ + liftIO $ rawSystem cmd args + when (ec /= ExitSuccess) $ error $ concat + [ "Process exited with " + , show ec + , ": " + , unwords (cmd:args) + ] + commands = + [ ("sudo", + [ "cp" + , toFilePath newFile + , toFilePath tmpFile + ]) + , ("sudo", + [ "mv" + , toFilePath tmpFile + , executablePath + ]) + ] + logInfo "Going to run the following commands:" + logInfo "" + forM_ commands $ \(cmd, args) -> + logInfo $ "- " `T.append` T.unwords (map T.pack (cmd:args)) + mapM_ (uncurry run) commands + logInfo "" + logInfo "sudo file copy worked!" + | otherwise -> throwM e + +prompt :: MonadIO m => String -> m Bool +prompt str = + liftIO go + where + go = do + putStr str + hFlush stdout + l <- getLine + case l of + 'y':_ -> return True + 'n':_ -> return False + _ -> putStrLn "Invalid entry, try again" >> go + getDownloadVersion :: StackReleaseInfo -> Maybe Version getDownloadVersion (StackReleaseInfo val) = do Object o <- Just val @@ -1829,4 +1985,4 @@ parseVersion $ T.drop 1 rawName stackVersion :: Version -stackVersion = fromCabalVersion Meta.version +stackVersion = fromCabalVersion (mkVersion' Meta.version) diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -21,37 +23,27 @@ , tempInstallDir ) where -import Control.Applicative -import Control.Monad.Catch -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger -import Control.Monad.Reader (MonadReader) -import Control.Monad.Trans.Control +import Stack.Prelude +import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as S8 import Data.List hiding (concat, elem, maximumBy) -import Data.Maybe -import Data.Monoid -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Distribution.System (Platform (..)) import qualified Distribution.System as Cabal -import GHC.Generics (Generic) import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Path import Path.IO -import Prelude hiding (concat, elem) -- Fix AMP warning import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT import Stack.Types.Version import System.Process.Read data Tool = Tool PackageIdentifier -- ^ e.g. ghc-7.8.4, msys2-20150512 - | ToolGhcjs CompilerVersion -- ^ e.g. ghcjs-0.1.0_ghc-7.10.2 + | ToolGhcjs (CompilerVersion 'CVActual) -- ^ e.g. ghcjs-0.1.0_ghc-7.10.2 toolString :: Tool -> String toolString (Tool ident) = packageIdentifierString ident @@ -72,13 +64,13 @@ -> m () markInstalled programsPath tool = do fpRel <- parseRelFile $ toolString tool ++ ".installed" - liftIO $ writeFile (toFilePath $ programsPath fpRel) "installed" + liftIO $ B.writeFile (toFilePath $ programsPath fpRel) "installed" -unmarkInstalled :: (MonadIO m, MonadCatch m) +unmarkInstalled :: MonadIO m => Path Abs Dir -> Tool -> m () -unmarkInstalled programsPath tool = do +unmarkInstalled programsPath tool = liftIO $ do fpRel <- parseRelFile $ toolString tool ++ ".installed" ignoringAbsence (removeFile $ programsPath fpRel) @@ -95,17 +87,22 @@ x <- T.stripSuffix ".installed" $ T.pack $ toFilePath $ filename fp parseToolText x -getCompilerVersion :: (MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m) - => EnvOverride -> WhichCompiler -> m CompilerVersion +getCompilerVersion + :: HasLogFunc env + => EnvOverride + -> WhichCompiler + -> RIO env (CompilerVersion 'CVActual) getCompilerVersion menv wc = case wc of Ghc -> do - $logDebug "Asking GHC for its version" + logDebug "Asking GHC for its version" bs <- readProcessStdout Nothing menv "ghc" ["--numeric-version"] let (_, ghcVersion) = versionFromEnd bs - GhcVersion <$> parseVersion (T.decodeUtf8 ghcVersion) + x <- GhcVersion <$> parseVersion (T.decodeUtf8 ghcVersion) + logDebug $ "GHC version is: " <> compilerVersionText x + return x Ghcjs -> do - $logDebug "Asking GHCJS for its version" + logDebug "Asking GHCJS for its version" -- Output looks like -- -- The Glorious Glasgow Haskell Compilation System for JavaScript, version 0.1.0 (GHC 7.10.2) @@ -118,9 +115,7 @@ isValid c = c == '.' || ('0' <= c && c <= '9') -- | Binary directories for the given installed package -extraDirs :: (StackM env m, HasConfig env) - => Tool - -> m ExtraDirs +extraDirs :: HasConfig env => Tool -> RIO env ExtraDirs extraDirs tool = do config <- view configL dir <- installDir (configLocalPrograms config) tool @@ -170,7 +165,7 @@ ] } (Platform _ x, toolName) -> do - $logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, toolName)) + logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, toolName)) return mempty where isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n diff --git a/src/Stack/SetupCmd.hs b/src/Stack/SetupCmd.hs --- a/src/Stack/SetupCmd.hs +++ b/src/Stack/SetupCmd.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -- | Install GHC/GHCJS and Cabal. module Stack.SetupCmd @@ -12,23 +13,21 @@ ) where import Control.Applicative -import Control.Monad.Logger +import Control.Monad.Logger () import Control.Monad.Reader -import Data.Monoid import qualified Data.Text as T import qualified Options.Applicative as OA import qualified Options.Applicative.Builder.Extra as OA import qualified Options.Applicative.Types as OA import Path -import Prelude -- silence redundant import warnings +import Stack.Prelude import Stack.Setup import Stack.Types.Compiler import Stack.Types.Config -import Stack.Types.StackT import Stack.Types.Version data SetupCmdOpts = SetupCmdOpts - { scoCompilerVersion :: !(Maybe CompilerVersion) + { scoCompilerVersion :: !(Maybe (CompilerVersion 'CVWanted)) , scoForceReinstall :: !Bool , scoUpgradeCabal :: !(Maybe UpgradeTo) , scoSetupInfoYaml :: !String @@ -101,12 +100,12 @@ Just x -> return x setup - :: (StackM env m, HasConfig env, HasGHCVariant env) + :: (HasConfig env, HasGHCVariant env) => SetupCmdOpts - -> CompilerVersion + -> CompilerVersion 'CVWanted -> VersionCheck -> Maybe (Path Abs File) - -> m () + -> RIO env () setup SetupCmdOpts{..} wantedCompiler compilerCheck mstack = do Config{..} <- view configL (_, _, sandboxedGhc) <- ensureCompiler SetupOpts @@ -129,8 +128,8 @@ GhcVersion _ -> "GHC" GhcjsVersion {} -> "GHCJS" if sandboxedGhc - then $logInfo $ "stack will use a sandboxed " <> compiler <> " it installed" - else $logInfo $ "stack will use the " <> compiler <> " on your PATH" - $logInfo "For more information on paths, see 'stack path' and 'stack exec env'" - $logInfo $ "To use this " <> compiler <> " and packages outside of a project, consider using:" - $logInfo "stack ghc, stack ghci, stack runghc, or stack exec" + then logInfo $ "stack will use a sandboxed " <> compiler <> " it installed" + else logInfo $ "stack will use the " <> compiler <> " on your PATH" + logInfo "For more information on paths, see 'stack path' and 'stack exec env'" + logInfo $ "To use this " <> compiler <> " and packages outside of a project, consider using:" + logInfo "stack ghc, stack ghci, stack runghc, or stack exec" diff --git a/src/Stack/Sig.hs b/src/Stack/Sig.hs --- a/src/Stack/Sig.hs +++ b/src/Stack/Sig.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-| Module : Stack.Sig Description : GPG Signatures for Stack diff --git a/src/Stack/Sig/GPG.hs b/src/Stack/Sig/GPG.hs --- a/src/Stack/Sig/GPG.hs +++ b/src/Stack/Sig/GPG.hs @@ -1,7 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TemplateHaskell #-} {-| Module : Stack.Sig.GPG @@ -15,23 +14,15 @@ module Stack.Sig.GPG (gpgSign, gpgVerify) where -import Prelude () -import Prelude.Compat - -import Control.Monad (unless, when) -import Control.Monad.Catch (MonadThrow, throwM) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger (MonadLogger, logWarn) +import Stack.Prelude import qualified Data.ByteString.Char8 as C import Data.List (find, isPrefixOf) -import Data.Monoid ((<>)) import qualified Data.Text as T -import Path import Stack.Types.Sig import System.Directory (findExecutable) import System.Environment (lookupEnv) import System.Exit (ExitCode(..)) -import System.IO (Handle, hGetContents, hPutStrLn) +import System.IO (hGetContents, hPutStrLn) import System.Info (os) import System.Process (ProcessHandle, runInteractiveProcess, waitForProcess) @@ -113,5 +104,5 @@ (do mTTY <- liftIO (lookupEnv "GPG_TTY") when (null mTTY) - ($logWarn + (logWarn "Environment variable GPG_TTY is not set (see `man gpg-agent`)")) diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs --- a/src/Stack/Sig/Sign.hs +++ b/src/Stack/Sig/Sign.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} {-| Module : Stack.Sig.Sign @@ -16,25 +16,17 @@ module Stack.Sig.Sign (sign, signPackage, signTarBytes) where -import Prelude () -import Prelude.Compat - import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip -import Control.Monad (when) -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Logger +import Stack.Prelude import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as L -import Data.Monoid ((<>)) import qualified Data.Text as T import Network.HTTP.Client (RequestBody (RequestBodyBS)) import Network.HTTP.Download import Network.HTTP.Simple import Network.HTTP.Types (methodPut) import Path -import Path.IO import Stack.Package import Stack.Sig.GPG import Stack.Types.PackageIdentifier @@ -45,12 +37,13 @@ -- service and a path to a tarball. sign #if __GLASGOW_HASKELL__ < 710 - :: (Applicative m, MonadIO m, MonadLogger m, MonadMask m) + :: (Applicative m, MonadUnliftIO m, MonadLogger m, MonadThrow m) #else - :: (MonadIO m, MonadLogger m, MonadMask m) + :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) #endif => String -> Path Abs File -> m Signature sign url filePath = + withRunInIO $ \run -> withSystemTempDir "stack" (\tempDir -> @@ -64,7 +57,7 @@ Nothing -> throwM SigInvalidSDistTarBall Just cabalPath -> do pkg <- cabalFilePackageId (tempDir cabalPath) - signPackage url pkg filePath) + run (signPackage url pkg filePath)) where extractCabalFile tempDir (Tar.Next entry entries) = case Tar.entryContent entry of @@ -90,9 +83,9 @@ -- the tarball with GPG. signTarBytes #if __GLASGOW_HASKELL__ < 710 - :: (Applicative m, MonadIO m, MonadLogger m, MonadMask m) + :: (Applicative m, MonadUnliftIO m, MonadLogger m, MonadThrow m) #else - :: (MonadIO m, MonadLogger m, MonadMask m) + :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) #endif => String -> Path Rel File -> L.ByteString -> m Signature signTarBytes url tarPath bs = @@ -123,5 +116,5 @@ when (getResponseStatusCode res /= 200) (throwM (GPGSignException "unable to sign & upload package")) - $logInfo ("Signature uploaded to " <> T.pack fullUrl) + logInfo ("Signature uploaded to " <> T.pack fullUrl) return sig diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Snapshot.hs @@ -0,0 +1,784 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Reading in @SnapshotDef@s and converting them into +-- @LoadedSnapshot@s. +module Stack.Snapshot + ( loadResolver + , loadSnapshot + , calculatePackagePromotion + ) where + +import Stack.Prelude +import Control.Monad.State.Strict (get, put, StateT, execStateT) +import Crypto.Hash.Conduit (hashFile) +import Data.Aeson (withObject, (.!=), (.:), (.:?), Value (Object)) +import Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings, (..!=), (..:?), jsonSubWarningsT, withObjectWarnings, (..:)) +import Data.Aeson.Types (Parser, parseEither) +import Data.Store.VersionTagged +import qualified Data.Conduit.List as CL +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Yaml (decodeFileEither, ParseException (AesonException)) +import Distribution.InstalledPackageInfo (PError) +import Distribution.PackageDescription (GenericPackageDescription) +import qualified Distribution.PackageDescription as C +import qualified Distribution.Types.UnqualComponentName as C +import Distribution.System (Platform) +import Distribution.Text (display) +import qualified Distribution.Version as C +import Network.HTTP.Client (Request) +import Network.HTTP.Download +import Path +import Path.IO +import Stack.Constants +import Stack.Fetch +import Stack.Package +import Stack.PackageDump +import Stack.PackageLocation +import Stack.Types.BuildPlan +import Stack.Types.FlagName +import Stack.Types.GhcPkgId +import Stack.Types.PackageIdentifier +import Stack.Types.PackageName +import Stack.Types.Version +import Stack.Types.VersionIntervals +import Stack.Types.Config +import Stack.Types.Urls +import Stack.Types.Compiler +import Stack.Types.Resolver +import qualified System.Directory as Dir + +type SinglePackageLocation = PackageLocationIndex FilePath + +data SnapshotException + = InvalidCabalFileInSnapshot !SinglePackageLocation !PError + | PackageDefinedTwice !PackageName !SinglePackageLocation !SinglePackageLocation + | UnmetDeps !(Map PackageName (Map PackageName (VersionIntervals, Maybe Version))) + | FilepathInCustomSnapshot !Text + | NeedResolverOrCompiler !Text + | MissingPackages !(Set PackageName) + | CustomResolverException !Text !(Either Request FilePath) !ParseException + deriving Typeable +instance Exception SnapshotException +instance Show SnapshotException where + show (InvalidCabalFileInSnapshot loc err) = concat + [ "Invalid cabal file at " + , show loc + , ": " + , show err + ] + show (PackageDefinedTwice name loc1 loc2) = concat + [ "Package " + , packageNameString name + , " is defined twice, at " + , show loc1 + , " and " + , show loc2 + ] + show (UnmetDeps m) = + concat $ "Some dependencies in the snapshot are unmet.\n" : map go (Map.toList m) + where + go (name, deps) = concat + $ "\n" + : packageNameString name + : " is missing:\n" + : map goDep (Map.toList deps) + + goDep (dep, (intervals, mversion)) = concat + [ "- " + , packageNameString dep + , ". Requires: " + , display $ toVersionRange intervals + , ", " + , case mversion of + Nothing -> "none present" + Just version -> versionString version ++ " found" + , "\n" + ] + show (FilepathInCustomSnapshot url) = + "Custom snapshots do not support filepaths, as the contents may change over time. Found in: " ++ + T.unpack url + show (NeedResolverOrCompiler url) = + "You must specify either a resolver or compiler value in " ++ + T.unpack url + show (MissingPackages names) = + "The following packages specified by flags or options are not found: " ++ + unwords (map packageNameString (Set.toList names)) + show (CustomResolverException url loc e) = concat + [ "Unable to load custom resolver " + , T.unpack url + , " from location\n" + , show loc + , "\nException: " + , show e + ] + +-- | Convert a 'Resolver' into a 'SnapshotDef' +loadResolver + :: forall env. HasConfig env + => Resolver + -> RIO env SnapshotDef +loadResolver (ResolverSnapshot name) = do + stackage <- view stackRootL + file' <- parseRelFile $ T.unpack file + cachePath <- (buildPlanCacheDir stackage ) <$> parseRelFile (T.unpack (renderSnapName name <> ".cache")) + let fp = buildPlanDir stackage file' + tryDecode = tryAny $ $(versionedDecodeOrLoad snapshotDefVC) cachePath $ liftIO $ do + evalue <- decodeFileEither $ toFilePath fp + case evalue of + Left e -> throwIO e + Right value -> + case parseEither parseStackageSnapshot value of + Left s -> throwIO $ AesonException s + Right x -> return x + logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp) + eres <- tryDecode + case eres of + Right sd -> return sd + Left e -> do + logDebug $ "Decoding Stackage snapshot definition from file failed: " <> T.pack (show e) + ensureDir (parent fp) + url <- buildBuildPlanUrl name file + req <- parseRequest $ T.unpack url + logSticky $ "Downloading " <> renderSnapName name <> " build plan ..." + logDebug $ "Downloading build plan from: " <> url + wasDownloaded <- redownload req fp + if wasDownloaded + then logStickyDone $ "Downloaded " <> renderSnapName name <> " build plan." + else logStickyDone $ "Skipped download of " <> renderSnapName name <> " because its the stored entity tag matches the server version" + tryDecode >>= either throwM return + + where + file = renderSnapName name <> ".yaml" + + buildBuildPlanUrl :: (MonadReader env m, HasConfig env) => SnapName -> Text -> m Text + buildBuildPlanUrl snapName file' = do + urls <- view $ configL.to configUrls + return $ + case snapName of + LTS _ _ -> urlsLtsBuildPlans urls <> "/" <> file' + Nightly _ -> urlsNightlyBuildPlans urls <> "/" <> file' + + parseStackageSnapshot = withObject "StackageSnapshotDef" $ \o -> do + Object si <- o .: "system-info" + ghcVersion <- si .:? "ghc-version" + compilerVersion <- si .:? "compiler-version" + compilerVersion' <- + case (ghcVersion, compilerVersion) of + (Just _, Just _) -> fail "can't have both compiler-version and ghc-version fields" + (Just ghc, _) -> return (GhcVersion ghc) + (_, Just compiler) -> return compiler + _ -> fail "expected field \"ghc-version\" or \"compiler-version\" not present" + let sdParent = Left compilerVersion' + sdGlobalHints <- si .: "core-packages" + + packages <- o .: "packages" + (Endo mkLocs, sdFlags, sdHidden) <- fmap mconcat $ mapM (uncurry goPkg) $ Map.toList packages + let sdLocations = mkLocs [] + + let sdGhcOptions = Map.empty -- Stackage snapshots do not allow setting GHC options + + -- Not dropping any packages in a Stackage snapshot + let sdDropPackages = Set.empty + + let sdResolver = ResolverSnapshot name + sdResolverName = renderSnapName name + + return SnapshotDef {..} + where + goPkg name' = withObject "StackagePackageDef" $ \o -> do + version <- o .: "version" + mcabalFileInfo <- o .:? "cabal-file-info" + mcabalFileInfo' <- forM mcabalFileInfo $ \o' -> do + msize <- Just <$> o' .: "size" + cfiHashes <- o' .: "hashes" + hash' <- + case HashMap.lookup ("SHA256" :: Text) cfiHashes of + Nothing -> fail "Could not find SHA256" + Just shaText -> + case mkCabalHashFromSHA256 shaText of + Left e -> fail $ "Invalid SHA256: " ++ show e + Right x -> return x + return $ CFIHash msize hash' + + Object constraints <- o .: "constraints" + + flags <- constraints .: "flags" + let flags' = Map.singleton name' flags + + hide <- constraints .:? "hide" .!= False + let hide' = if hide then Map.singleton name' True else Map.empty + + let location = PLIndex $ PackageIdentifierRevision (PackageIdentifier name' version) (fromMaybe CFILatest mcabalFileInfo') + + return (Endo (location:), flags', hide') +loadResolver (ResolverCompiler compiler) = return SnapshotDef + { sdParent = Left compiler + , sdResolver = ResolverCompiler compiler + , sdResolverName = compilerVersionText compiler + , sdLocations = [] + , sdDropPackages = Set.empty + , sdFlags = Map.empty + , sdHidden = Map.empty + , sdGhcOptions = Map.empty + , sdGlobalHints = Map.empty + } +loadResolver (ResolverCustom url loc) = do + logDebug $ "Loading " <> url <> " build plan from " <> T.pack (show loc) + case loc of + Left req -> download' req >>= load . toFilePath + Right fp -> load fp + where + download' :: Request -> RIO env (Path Abs File) + download' req = do + let urlHash = T.unpack $ trimmedSnapshotHash $ snapshotHashFromBS $ encodeUtf8 url + hashFP <- parseRelFile $ urlHash ++ ".yaml" + customPlanDir <- getCustomPlanDir + let cacheFP = customPlanDir $(mkRelDir "yaml") hashFP + void (download req cacheFP :: RIO env Bool) + return cacheFP + + getCustomPlanDir = do + root <- view stackRootL + return $ root $(mkRelDir "custom-plan") + + load :: FilePath -> RIO env SnapshotDef + load fp = do + WithJSONWarnings (sd0, mparentResolver, mcompiler) warnings <- + liftIO (decodeFileEither fp) >>= either + (throwM . CustomResolverException url loc) + (either (throwM . AesonException) return . parseEither parseCustom) + logJSONWarnings (T.unpack url) warnings + + forM_ (sdLocations sd0) $ \loc' -> + case loc' of + PLOther (PLFilePath _) -> throwM $ FilepathInCustomSnapshot url + _ -> return () + + -- The fp above may just be the download location for a URL, + -- which we don't want to use. Instead, look back at loc from + -- above. + mdir <- + case loc of + Left _ -> return Nothing + Right fp' -> (Just . parent) <$> liftIO (Dir.canonicalizePath fp' >>= parseAbsFile) + + -- Deal with the dual nature of the compiler key, which either + -- means "use this compiler" or "override the compiler in the + -- resolver" + (parentResolver, overrideCompiler) <- + case (mparentResolver, mcompiler) of + (Nothing, Nothing) -> throwM $ NeedResolverOrCompiler url + (Just parentResolver, Nothing) -> return (parentResolver, id) + (Nothing, Just compiler) -> return (ResolverCompiler compiler, id) + (Just parentResolver, Just compiler) -> return + ( parentResolver + , setCompilerVersion compiler + ) + + parentResolver' <- parseCustomLocation mdir parentResolver + + -- Calculate the hash of the current file, and then combine it + -- with parent hashes if necessary below. + rawHash :: SnapshotHash <- snapshotHashFromDigest <$> hashFile fp :: RIO env SnapshotHash + + (parent', hash') <- + case parentResolver' of + ResolverCompiler cv -> return (Left cv, rawHash) -- just a small optimization + _ -> do + parent' :: SnapshotDef <- loadResolver (parentResolver' :: Resolver) :: RIO env SnapshotDef + let hash' :: SnapshotHash + hash' = combineHash rawHash $ + case sdResolver parent' of + ResolverSnapshot snapName -> snapNameToHash snapName + ResolverCustom _ parentHash -> parentHash + ResolverCompiler _ -> error "loadResolver: Receieved ResolverCompiler in impossible location" + return (Right parent', hash') + return $ overrideCompiler sd0 + { sdParent = parent' + , sdResolver = ResolverCustom url hash' + } + + -- | Note that the 'sdParent' and 'sdResolver' fields returned + -- here are bogus, and need to be replaced with information only + -- available after further processing. + parseCustom :: Value + -> Parser (WithJSONWarnings (SnapshotDef, Maybe (ResolverWith ()), Maybe (CompilerVersion 'CVWanted))) + parseCustom = withObjectWarnings "CustomSnapshot" $ \o -> (,,) + <$> (SnapshotDef (Left (error "loadResolver")) (ResolverSnapshot (LTS 0 0)) + <$> (o ..: "name") + <*> jsonSubWarningsT (o ..:? "packages" ..!= []) + <*> o ..:? "drop-packages" ..!= Set.empty + <*> o ..:? "flags" ..!= Map.empty + <*> o ..:? "hidden" ..!= Map.empty + <*> o ..:? "ghc-options" ..!= Map.empty + <*> o ..:? "global-hints" ..!= Map.empty) + <*> (o ..:? "resolver") + <*> (o ..:? "compiler") + + combineHash :: SnapshotHash -> SnapshotHash -> SnapshotHash + combineHash x y = snapshotHashFromBS (snapshotHashToBS x <> snapshotHashToBS y) + + snapNameToHash :: SnapName -> SnapshotHash + snapNameToHash = snapshotHashFromBS . encodeUtf8 . renderSnapName + +-- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot' +loadSnapshot + :: forall env. + (HasConfig env, HasGHCVariant env) + => Maybe (CompilerVersion 'CVActual) -- ^ installed GHC we should query; if none provided, use the global hints + -> Path Abs Dir -- ^ project root, used for checking out necessary files + -> SnapshotDef + -> RIO env LoadedSnapshot +loadSnapshot mcompiler root sd = withCabalLoader $ \loader -> loadSnapshot' loader mcompiler root sd + +-- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot' +loadSnapshot' + :: forall env. + (HasConfig env, HasGHCVariant env) + => (PackageIdentifierRevision -> IO ByteString) -- ^ load a cabal file's contents from the index + -> Maybe (CompilerVersion 'CVActual) -- ^ installed GHC we should query; if none provided, use the global hints + -> Path Abs Dir -- ^ project root, used for checking out necessary files + -> SnapshotDef + -> RIO env LoadedSnapshot +loadSnapshot' loadFromIndex mcompiler root = + start + where + start (snapshotDefFixes -> sd) = do + path <- configLoadedSnapshotCache + sd + (maybe GISSnapshotHints GISCompiler mcompiler) + $(versionedDecodeOrLoad loadedSnapshotVC) path (inner sd) + + inner :: SnapshotDef -> RIO env LoadedSnapshot + inner sd = do + ls0 <- + case sdParent sd of + Left cv -> + case mcompiler of + Nothing -> return LoadedSnapshot + { lsCompilerVersion = wantedToActual cv + , lsGlobals = fromGlobalHints $ sdGlobalHints sd + , lsPackages = Map.empty + } + Just cv' -> loadCompiler cv' + Right sd' -> start sd' + + gpds <- + (concat <$> mapM (parseMultiCabalFilesIndex loadFromIndex root) (sdLocations sd)) + `onException` do + logError "Unable to load cabal files for snapshot" + case sdResolver sd of + ResolverSnapshot name -> do + stackRoot <- view stackRootL + file <- parseRelFile $ T.unpack $ renderSnapName name <> ".yaml" + let fp = buildPlanDir stackRoot file + liftIO $ ignoringAbsence $ removeFile fp + logError "" + logError "----" + logError $ "Deleting cached snapshot file: " <> T.pack (toFilePath fp) + logError "Recommendation: try running again. If this fails again, open an upstream issue at:" + logError $ + case name of + LTS _ _ -> "https://github.com/fpco/lts-haskell/issues/new" + Nightly _ -> "https://github.com/fpco/stackage-nightly/issues/new" + logError "----" + logError "" + _ -> return () + + (globals, snapshot, locals) <- + calculatePackagePromotion loadFromIndex root ls0 + (map (\(x, y) -> (x, y, ())) gpds) + (sdFlags sd) (sdHidden sd) (sdGhcOptions sd) (sdDropPackages sd) + + return LoadedSnapshot + { lsCompilerVersion = lsCompilerVersion ls0 + , lsGlobals = globals + -- When applying a snapshot on top of another one, we merge + -- the two snapshots' packages together. + , lsPackages = Map.union snapshot (Map.map (fmap fst) locals) + } + +-- | Given information on a 'LoadedSnapshot' and a given set of +-- additional packages and configuration values, calculates the new +-- global and snapshot packages, as well as the new local packages. +-- +-- The new globals and snapshots must be a subset of the initial +-- values. +calculatePackagePromotion + :: forall env localLocation. + (HasConfig env, HasGHCVariant env) + => (PackageIdentifierRevision -> IO ByteString) -- ^ load from index + -> Path Abs Dir -- ^ project root + -> LoadedSnapshot + -> [(GenericPackageDescription, SinglePackageLocation, localLocation)] -- ^ packages we want to add on top of this snapshot + -> Map PackageName (Map FlagName Bool) -- ^ flags + -> Map PackageName Bool -- ^ overrides whether a package should be registered hidden + -> Map PackageName [Text] -- ^ GHC options + -> Set PackageName -- ^ packages in the snapshot to drop + -> RIO env + ( Map PackageName (LoadedPackageInfo GhcPkgId) -- new globals + , Map PackageName (LoadedPackageInfo SinglePackageLocation) -- new snapshot + , Map PackageName (LoadedPackageInfo (SinglePackageLocation, Maybe localLocation)) -- new locals + ) +calculatePackagePromotion + loadFromIndex root (LoadedSnapshot compilerVersion globals0 parentPackages0) + gpds flags0 hides0 options0 drops0 = do + + platform <- view platformL + + -- Hand out flags, hide, and GHC options to the newly added + -- packages + (packages1, flags, hide, ghcOptions) <- execStateT + (mapM_ (findPackage platform compilerVersion) gpds) + (Map.empty, flags0, hides0, options0) + + let + -- We need to drop all packages from globals and parent + -- packages that are either marked to be dropped, or + -- included in the new packages. + toDrop = Map.union (void packages1) (Map.fromSet (const ()) drops0) + globals1 = Map.difference globals0 toDrop + parentPackages1 = Map.difference parentPackages0 toDrop + + -- The set of all packages that need to be upgraded based on + -- newly set flags, hide values, or GHC options + toUpgrade = Set.unions [Map.keysSet flags, Map.keysSet hide, Map.keysSet ghcOptions] + + -- Perform a sanity check: ensure that all of the packages + -- that need to be upgraded actually exist in the global or + -- parent packages + oldNames = Set.union (Map.keysSet globals1) (Map.keysSet parentPackages1) + extraToUpgrade = Set.difference toUpgrade oldNames + unless (Set.null extraToUpgrade) $ throwM $ MissingPackages extraToUpgrade + + let + -- Split up the globals into those that are to be upgraded + -- (no longer globals) and those that remain globals, based + -- solely on the toUpgrade value + (noLongerGlobals1, globals2) = Map.partitionWithKey + (\name _ -> name `Set.member` toUpgrade) + globals1 + -- Further: now that we've removed a bunch of packages from + -- globals, split out any packages whose dependencies are no + -- longer met + (globals3, noLongerGlobals2) = splitUnmetDeps Map.empty globals2 + + -- Put together the two split out groups of packages + noLongerGlobals3 :: Map PackageName (LoadedPackageInfo SinglePackageLocation) + noLongerGlobals3 = Map.union (Map.mapWithKey globalToSnapshot noLongerGlobals1) noLongerGlobals2 + + -- Now do the same thing with parent packages: take out the + -- packages to be upgraded and then split out unmet + -- dependencies. + (noLongerParent1, parentPackages2) = Map.partitionWithKey + (\name _ -> name `Set.member` toUpgrade) + parentPackages1 + (parentPackages3, noLongerParent2) = splitUnmetDeps + (Map.map lpiVersion globals3) + parentPackages2 + noLongerParent3 = Map.union noLongerParent1 noLongerParent2 + + -- Everything split off from globals and parents will be upgraded... + allToUpgrade = Map.union noLongerGlobals3 noLongerParent3 + + -- ... so recalculate based on new values + upgraded <- fmap Map.fromList + $ mapM (recalculate loadFromIndex root compilerVersion flags hide ghcOptions) + $ Map.toList allToUpgrade + + -- Could be nice to check snapshot early... but disabling + -- because ConstructPlan gives much nicer error messages + let packages2 = Map.unions [Map.map void upgraded, Map.map void packages1, Map.map void parentPackages3] + allAvailable = Map.union + (lpiVersion <$> globals3) + (lpiVersion <$> packages2) + when False $ checkDepsMet allAvailable packages2 + + unless (Map.null (globals3 `Map.difference` globals0)) + (error "calculatePackagePromotion: subset invariant violated for globals") + unless (Map.null (parentPackages3 `Map.difference` parentPackages0)) + (error "calculatePackagePromotion: subset invariant violated for parents") + + return + ( globals3 + , parentPackages3 + , Map.union (Map.map (fmap (, Nothing)) upgraded) (Map.map (fmap (second Just)) packages1) + ) + +-- | Recalculate a 'LoadedPackageInfo' based on updates to flags, +-- hide values, and GHC options. +recalculate :: forall env. + (HasConfig env, HasGHCVariant env) + => (PackageIdentifierRevision -> IO ByteString) + -> Path Abs Dir -- ^ root + -> CompilerVersion 'CVActual + -> Map PackageName (Map FlagName Bool) + -> Map PackageName Bool -- ^ hide? + -> Map PackageName [Text] -- ^ GHC options + -> (PackageName, LoadedPackageInfo SinglePackageLocation) + -> RIO env (PackageName, LoadedPackageInfo SinglePackageLocation) +recalculate loadFromIndex root compilerVersion allFlags allHide allOptions (name, lpi0) = do + let hide = fromMaybe (lpiHide lpi0) (Map.lookup name allHide) + options = fromMaybe (lpiGhcOptions lpi0) (Map.lookup name allOptions) + case Map.lookup name allFlags of + Nothing -> return (name, lpi0 { lpiHide = hide, lpiGhcOptions = options }) -- optimization + Just flags -> do + let loc = lpiLocation lpi0 + gpd <- parseSingleCabalFileIndex loadFromIndex root loc + platform <- view platformL + let res@(name', lpi) = calculate gpd platform compilerVersion loc flags hide options + unless (name == name' && lpiVersion lpi0 == lpiVersion lpi) $ error "recalculate invariant violated" + return res + +fromGlobalHints :: Map PackageName (Maybe Version) -> Map PackageName (LoadedPackageInfo GhcPkgId) +fromGlobalHints = + Map.unions . map go . Map.toList + where + go (_, Nothing) = Map.empty + go (name, Just ver) = Map.singleton name LoadedPackageInfo + { lpiVersion = ver + -- For global hint purposes, we only care about the + -- version. All other fields are ignored when checking + -- project compatibility. + , lpiLocation = either impureThrow id + $ parseGhcPkgId + $ packageIdentifierText + $ PackageIdentifier name ver + , lpiFlags = Map.empty + , lpiGhcOptions = [] + , lpiPackageDeps = Map.empty + , lpiProvidedExes = Set.empty + , lpiNeededExes = Map.empty + , lpiExposedModules = Set.empty + , lpiHide = False + } + +-- | Ensure that all of the dependencies needed by this package +-- are available in the given Map of packages. +checkDepsMet :: MonadThrow m + => Map PackageName Version -- ^ all available packages + -> Map PackageName (LoadedPackageInfo localLocation) + -> m () +checkDepsMet available m + | Map.null errs = return () + | otherwise = throwM $ UnmetDeps errs + where + errs = foldMap (uncurry go) (Map.toList m) + + go :: PackageName + -> LoadedPackageInfo loc + -> Map PackageName (Map PackageName (VersionIntervals, Maybe Version)) + go name lpi + | Map.null errs' = Map.empty + | otherwise = Map.singleton name errs' + where + errs' = foldMap (uncurry goDep) (Map.toList (lpiPackageDeps lpi)) + + goDep :: PackageName -> VersionIntervals -> Map PackageName (VersionIntervals, Maybe Version) + goDep name intervals = + case Map.lookup name available of + Nothing -> Map.singleton name (intervals, Nothing) + Just version + | version `withinIntervals` intervals -> Map.empty + | otherwise -> Map.singleton name (intervals, Just version) + +-- | Load a snapshot from the given compiler version, using just the +-- information in the global package database. +loadCompiler :: forall env. + HasConfig env + => CompilerVersion 'CVActual + -> RIO env LoadedSnapshot +loadCompiler cv = do + menv <- getMinimalEnvOverride + m <- ghcPkgDump menv (whichCompiler cv) [] + (conduitDumpPackage .| CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp)) + return LoadedSnapshot + { lsCompilerVersion = cv + , lsGlobals = toGlobals m + , lsPackages = Map.empty + } + where + toGlobals :: Map GhcPkgId (DumpPackage () () ()) + -> Map PackageName (LoadedPackageInfo GhcPkgId) + toGlobals m = + Map.fromList $ map go $ Map.elems m + where + identMap = Map.map dpPackageIdent m + + go :: DumpPackage () () () -> (PackageName, LoadedPackageInfo GhcPkgId) + go dp = + (name, lpi) + where + PackageIdentifier name version = dpPackageIdent dp + + goDep ghcPkgId = + case Map.lookup ghcPkgId identMap of + Nothing -> Map.empty + Just (PackageIdentifier name' _) -> Map.singleton name' (fromVersionRange C.anyVersion) + + lpi :: LoadedPackageInfo GhcPkgId + lpi = LoadedPackageInfo + { lpiVersion = version + , lpiLocation = dpGhcPkgId dp + , lpiFlags = Map.empty + , lpiGhcOptions = [] + , lpiPackageDeps = Map.unions $ map goDep $ dpDepends dp + , lpiProvidedExes = Set.empty + , lpiNeededExes = Map.empty + , lpiExposedModules = Set.fromList $ map (ModuleName . encodeUtf8) $ dpExposedModules dp + , lpiHide = not $ dpIsExposed dp + } + +type FindPackageS localLocation = + ( Map PackageName (LoadedPackageInfo (SinglePackageLocation, localLocation)) + , Map PackageName (Map FlagName Bool) -- flags + , Map PackageName Bool -- hide + , Map PackageName [Text] -- ghc options + ) + +-- | Find the package at the given 'PackageLocation', grab any flags, +-- hidden state, and GHC options from the 'StateT' (removing them from +-- the 'StateT'), and add the newly found package to the contained +-- 'Map'. +findPackage :: forall m localLocation. + MonadThrow m + => Platform + -> CompilerVersion 'CVActual + -> (GenericPackageDescription, SinglePackageLocation, localLocation) + -> StateT (FindPackageS localLocation) m () +findPackage platform compilerVersion (gpd, loc, localLoc) = do + (m, allFlags, allHide, allOptions) <- get + + case Map.lookup name m of + Nothing -> return () + Just lpi -> throwM $ PackageDefinedTwice name loc (fst (lpiLocation lpi)) + + let flags = fromMaybe Map.empty $ Map.lookup name allFlags + allFlags' = Map.delete name allFlags + + hide = fromMaybe False $ Map.lookup name allHide + allHide' = Map.delete name allHide + + options = fromMaybe [] $ Map.lookup name allOptions + allOptions' = Map.delete name allOptions + + (name', lpi) = calculate gpd platform compilerVersion (loc, localLoc) flags hide options + m' = Map.insert name lpi m + + assert (name == name') $ put (m', allFlags', allHide', allOptions') + where + PackageIdentifier name _version = fromCabalPackageIdentifier $ C.package $ C.packageDescription gpd + +-- | Some hard-coded fixes for build plans, hopefully to be irrelevant over +-- time. +snapshotDefFixes :: SnapshotDef -> SnapshotDef +snapshotDefFixes sd | isStackage (sdResolver sd) = sd + { sdFlags = Map.unionWith Map.union overrides $ sdFlags sd + } + where + overrides = Map.fromList + [ ($(mkPackageName "persistent-sqlite"), Map.singleton $(mkFlagName "systemlib") False) + , ($(mkPackageName "yaml"), Map.singleton $(mkFlagName "system-libyaml") False) + ] + + isStackage (ResolverSnapshot _) = True + isStackage _ = False +snapshotDefFixes sd = sd + +-- | Convert a global 'LoadedPackageInfo' to a snapshot one by +-- creating a 'PackageLocation'. +globalToSnapshot :: PackageName -> LoadedPackageInfo loc -> LoadedPackageInfo (PackageLocationIndex FilePath) +globalToSnapshot name lpi = lpi + { lpiLocation = PLIndex (PackageIdentifierRevision (PackageIdentifier name (lpiVersion lpi)) CFILatest) + } + +-- | Split the globals into those which have their dependencies met, +-- and those that don't. This deals with promotion of globals to +-- snapshot when another global has been upgraded already. +splitUnmetDeps :: Map PackageName Version -- ^ extra dependencies available + -> Map PackageName (LoadedPackageInfo loc) + -> ( Map PackageName (LoadedPackageInfo loc) + , Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) + ) +splitUnmetDeps extra = + start Map.empty . Map.toList + where + start newGlobals0 toProcess0 + | anyAdded = start newGlobals1 toProcess1 + | otherwise = (newGlobals1, Map.mapWithKey globalToSnapshot $ Map.fromList toProcess1) + where + (newGlobals1, toProcess1, anyAdded) = loop False newGlobals0 id toProcess0 + + loop anyAdded newGlobals front [] = (newGlobals, front [], anyAdded) + loop anyAdded newGlobals front (x@(k, v):xs) + | depsMet newGlobals v = loop True (Map.insert k v newGlobals) front xs + | otherwise = loop anyAdded newGlobals (front . (x:)) xs + + depsMet globals = all (depsMet' globals) . Map.toList . lpiPackageDeps + + depsMet' globals (name, intervals) = + case (lpiVersion <$> Map.lookup name globals) <|> Map.lookup name extra of + Nothing -> False + Just version -> version `withinIntervals` intervals + +-- | Calculate a 'LoadedPackageInfo' from the given 'GenericPackageDescription' +calculate :: GenericPackageDescription + -> Platform + -> CompilerVersion 'CVActual + -> loc + -> Map FlagName Bool + -> Bool -- ^ hidden? + -> [Text] -- ^ GHC options + -> (PackageName, LoadedPackageInfo loc) +calculate gpd platform compilerVersion loc flags hide options = + (name, lpi) + where + pconfig = PackageConfig + { packageConfigEnableTests = False + , packageConfigEnableBenchmarks = False + , packageConfigFlags = flags + , packageConfigGhcOptions = options + , packageConfigCompilerVersion = compilerVersion + , packageConfigPlatform = platform + } + -- We want to ignore test suites and benchmarks, therefore choose + -- the package description which modifies buildable + pd = pdpModifiedBuildable $ resolvePackageDescription pconfig gpd + PackageIdentifier name version = fromCabalPackageIdentifier $ C.package pd + lpi = LoadedPackageInfo + { lpiVersion = version + , lpiLocation = loc + , lpiFlags = flags + , lpiGhcOptions = options + , lpiPackageDeps = Map.map fromVersionRange + $ Map.filterWithKey (const . (/= name)) + $ packageDependencies pd + , lpiProvidedExes = + Set.fromList + $ map (ExeName . T.pack . C.unUnqualComponentName . C.exeName) + $ C.executables pd + , lpiNeededExes = Map.map fromVersionRange + $ packageDescTools pd + , lpiExposedModules = maybe + Set.empty + (Set.fromList . map fromCabalModuleName . C.exposedModules) + (C.library pd) + , lpiHide = hide + } diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -6,49 +8,31 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Stack.Solver - ( checkResolverSpec - , cabalPackagesCheck - , findCabalFiles + ( cabalPackagesCheck + , findCabalDirs , getResolverConstraints , mergeConstraints , solveExtraDeps , solveResolverSpec + , checkSnapBuildPlanActual -- * Internal - for tests , parseCabalOutputLine ) where -import Prelude () -import Prelude.Compat - -import Control.Applicative -import Control.Exception (assert) -import Control.Exception.Safe (tryIO) -import Control.Monad (when,void,join,liftM,unless,mapAndUnzipM, zipWithM_) -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Logger +import Stack.Prelude import Data.Aeson.Extended (object, (.=), toJSON) import qualified Data.ByteString as S import Data.Char (isSpace) -import Data.Either -import Data.Foldable (forM_) -import Data.Function (on) import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet import Data.List ( (\\), isSuffixOf, intercalate , minimumBy, isPrefixOf) import Data.List.Extra (groupSortOn) -import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (catMaybes, isNothing, mapMaybe) -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) -import Data.Text.Extra (stripCR) import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Encoding (decodeUtf8With) import Data.Tuple (swap) @@ -56,26 +40,28 @@ import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C import qualified Distribution.Text as C +import Lens.Micro (set) import Path import Path.Find (findFiles) -import Path.IO hiding (findExecutable, findFiles) +import Path.IO hiding (findExecutable, findFiles, withSystemTempDir) +import Stack.Build.Target (gpdVersion) import Stack.BuildPlan import Stack.Config (getLocalPackages, loadConfigYaml) import Stack.Constants (stackDotYaml, wiredInPackages) -import Stack.Package (printCabalFileWarning - , hpack - , readPackageUnresolved) +import Stack.Package (readPackageUnresolvedDir, gpdPackageName) import Stack.PrettyPrint import Stack.Setup import Stack.Setup.Installed +import Stack.Snapshot (loadSnapshot) import Stack.Types.Build +import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Resolver -import Stack.Types.StackT (StackM) +import Stack.Types.Runner import Stack.Types.Version import qualified System.Directory as D import qualified System.FilePath as FP @@ -87,15 +73,14 @@ data ConstraintType = Constraint | Preference deriving (Eq) type ConstraintSpec = Map PackageName (Version, Map FlagName Bool) -cabalSolver :: (StackM env m, HasConfig env) - => EnvOverride - -> [Path Abs Dir] -- ^ cabal files +cabalSolver :: HasConfig env + => [Path Abs Dir] -- ^ cabal files -> ConstraintType -> ConstraintSpec -- ^ src constraints -> ConstraintSpec -- ^ dep constraints -> [String] -- ^ additional arguments - -> m (Either [PackageName] ConstraintSpec) -cabalSolver menv cabalfps constraintType + -> RIO env (Either [PackageName] ConstraintSpec) +cabalSolver cabalfps constraintType srcConstraints depConstraints cabalArgs = withSystemTempDir "cabal-solver" $ \dir' -> do @@ -126,6 +111,7 @@ toConstraintArgs (flagConstraints constraintType) ++ fmap toFilePath cabalfps + menv <- getMinimalEnvOverride catch (liftM Right (readProcessStdout (Just tmpdir) menv "cabal" args)) (\ex -> case ex of ProcessFailed _ _ _ err -> return $ Left err @@ -146,15 +132,15 @@ msg = LT.toStrict $ decodeUtf8With lenientDecode err if errCheck msg then do - $logInfo "Attempt failed.\n" - $logInfo $ cabalBuildErrMsg msg + logInfo "Attempt failed.\n" + logInfo $ cabalBuildErrMsg msg let pkgs = parseConflictingPkgs msg mPkgNames = map (C.simpleParse . T.unpack) pkgs pkgNames = map (fromCabalPackageName . C.pkgName) (catMaybes mPkgNames) when (any isNothing mPkgNames) $ do - $logInfo $ "*** Only some package names could be parsed: " <> + logInfo $ "*** Only some package names could be parsed: " <> T.pack (intercalate ", " (map show pkgNames)) error $ T.unpack $ "*** User packages involved in cabal failure: " @@ -234,11 +220,11 @@ lexeme r = some (psym isSpace) *> r -getCabalConfig :: (StackM env m, HasConfig env) +getCabalConfig :: HasConfig env => FilePath -- ^ temp dir -> ConstraintType -> Map PackageName Version -- ^ constraints - -> m [Text] + -> RIO env [Text] getCabalConfig dir constraintType constraints = do indices <- view $ configL.to configPackageIndices remotes <- mapM goIndex indices @@ -276,9 +262,9 @@ ] setupCompiler - :: (StackM env m, HasConfig env, HasGHCVariant env) - => CompilerVersion - -> m (Maybe ExtraDirs) + :: (HasConfig env, HasGHCVariant env) + => CompilerVersion 'CVWanted + -> RIO env (Maybe ExtraDirs) setupCompiler compiler = do let msg = Just $ T.concat [ "Compiler version (" <> compilerVersionText compiler <> ") " @@ -306,11 +292,14 @@ } return dirs +-- | Runs the given inner command with an updated configuration that +-- has the desired GHC on the PATH. setupCabalEnv - :: (StackM env m, HasConfig env, HasGHCVariant env) - => CompilerVersion - -> m EnvOverride -setupCabalEnv compiler = do + :: (HasConfig env, HasGHCVariant env) + => CompilerVersion 'CVWanted + -> (CompilerVersion 'CVActual -> RIO env a) + -> RIO env a +setupCabalEnv compiler inner = do mpaths <- setupCompiler compiler menv0 <- getMinimalEnvOverride envMap <- removeHaskellEnvVars @@ -323,25 +312,28 @@ case mcabal of Nothing -> throwM SolverMissingCabalInstall Just version - | version < $(mkVersion "1.24") -> $prettyWarn $ + | version < $(mkVersion "1.24") -> prettyWarn $ "Installed version of cabal-install (" <> display version <> ") doesn't support custom-setup clause, and so may not yield correct results." <> line <> "To resolve this, install a newer version via 'stack install cabal-install'." <> line - | version >= $(mkVersion "1.25") -> $prettyWarn $ + | version >= $(mkVersion "1.25") -> prettyWarn $ "Installed version of cabal-install (" <> display version <> ") is newer than stack has been tested with. If you run into difficulties, consider downgrading." <> line | otherwise -> return () mver <- getSystemCompiler menv (whichCompiler compiler) - case mver of - Just (version, _) -> - $logInfo $ "Using compiler: " <> compilerVersionText version + version <- case mver of + Just (version, _) -> do + logInfo $ "Using compiler: " <> compilerVersionText version + return version Nothing -> error "Failed to determine compiler version. \ \This is most likely a bug." - return menv + env <- set envOverrideL (const (return menv)) <$> ask + runRIO env (inner version) + -- | Merge two separate maps, one defining constraints on package versions and -- the other defining package flagmap, into a single map of version and flagmap -- tuples. @@ -371,23 +363,25 @@ -- or the solution in terms of src package flag settings and extra -- dependencies. solveResolverSpec - :: (StackM env m, HasConfig env, HasGHCVariant env) + :: (HasConfig env, HasGHCVariant env) => Path Abs File -- ^ stack.yaml file location -> [Path Abs Dir] -- ^ package dirs containing cabal files - -> ( Resolver + -> ( SnapshotDef , ConstraintSpec , ConstraintSpec) -- ^ ( resolver -- , src package constraints -- , extra dependency constraints ) - -> m (Either [PackageName] (ConstraintSpec , ConstraintSpec)) + -> RIO env + (Either [PackageName] (ConstraintSpec , ConstraintSpec)) -- ^ (Conflicting packages -- (resulting src package specs, external dependency specs)) solveResolverSpec stackYaml cabalDirs - (resolver, srcConstraints, extraConstraints) = do - $logInfo $ "Using resolver: " <> resolverName resolver - (compilerVer, snapConstraints) <- getResolverConstraints stackYaml resolver - menv <- setupCabalEnv compilerVer + (sd, srcConstraints, extraConstraints) = do + logInfo $ "Using resolver: " <> sdResolverName sd + let wantedCompilerVersion = sdWantedCompilerVersion sd + setupCabalEnv wantedCompilerVersion $ \compilerVersion -> do + (compilerVer, snapConstraints) <- getResolverConstraints (Just compilerVersion) stackYaml sd let -- Note - The order in Map.union below is important. -- We want to override snapshot with extra deps @@ -397,24 +391,24 @@ -- 1. We do not want snapshot versions to override the sources -- 2. Sources may have blank versions leading to bad cabal constraints depOnlyConstraints = Map.difference depConstraints srcConstraints - solver t = cabalSolver menv cabalDirs t srcConstraints depOnlyConstraints $ + solver t = cabalSolver cabalDirs t srcConstraints depOnlyConstraints $ "-v" : -- TODO make it conditional on debug ["--ghcjs" | whichCompiler compilerVer == Ghcjs] let srcNames = T.intercalate " and " $ - ["packages from " <> resolverName resolver + ["packages from " <> sdResolverName sd | not (Map.null snapConstraints)] ++ [T.pack (show (Map.size extraConstraints) <> " external packages") | not (Map.null extraConstraints)] - $logInfo "Asking cabal to calculate a build plan..." + logInfo "Asking cabal to calculate a build plan..." unless (Map.null depOnlyConstraints) - ($logInfo $ "Trying with " <> srcNames <> " as hard constraints...") + (logInfo $ "Trying with " <> srcNames <> " as hard constraints...") eresult <- solver Constraint eresult' <- case eresult of Left _ | not (Map.null depOnlyConstraints) -> do - $logInfo $ "Retrying with " <> srcNames <> " as preferences..." + logInfo $ "Retrying with " <> srcNames <> " as preferences..." solver Preference _ -> return eresult @@ -429,6 +423,15 @@ -- returned versions or flags different from the snapshot. inSnapChanged = Map.differenceWith diffConstraints inSnap snapConstraints + + -- If a package appears in both the + -- snapshot and locally, we don't want to + -- include it in extra-deps. This makes + -- sure we filter out such packages. See: + -- https://github.com/commercialhaskell/stack/issues/3533 + + `Map.difference` srcConstraints + -- Packages neither in snapshot, nor srcs extra = Map.difference deps (Map.union srcConstraints snapConstraints) @@ -451,13 +454,13 @@ error $ T.unpack $ msg <> showItems (map show (Map.toList bothVers)) - $logInfo $ "Successfully determined a build plan with " + logInfo $ "Successfully determined a build plan with " <> T.pack (show $ Map.size external) <> " external dependencies." return $ Right (srcs, external) Left x -> do - $logInfo $ "*** Failed to arrive at a workable build plan." + logInfo "*** Failed to arrive at a workable build plan." return $ Left x where -- Think of the first map as the deps reported in cabal output and @@ -478,49 +481,36 @@ -- return the compiler version, package versions and packages flags -- for that resolver. getResolverConstraints - :: (StackM env m, HasConfig env, HasGHCVariant env) - => Path Abs File - -> Resolver - -> m (CompilerVersion, + :: (HasConfig env, HasGHCVariant env) + => Maybe (CompilerVersion 'CVActual) -- ^ actually installed compiler + -> Path Abs File + -> SnapshotDef + -> RIO env + (CompilerVersion 'CVActual, Map PackageName (Version, Map FlagName Bool)) -getResolverConstraints stackYaml resolver = do - (mbp, _loadedResolver) <- loadResolver (Just stackYaml) resolver - return (mbpCompilerVersion mbp, mbpConstraints mbp) +getResolverConstraints mcompilerVersion stackYaml sd = do + ls <- loadSnapshot mcompilerVersion (parent stackYaml) sd + return (lsCompilerVersion ls, lsConstraints ls) where - mpiConstraints mpi = (mpiVersion mpi, mpiFlags mpi) - mbpConstraints mbp = fmap mpiConstraints (mbpPackages mbp) - --- | Given a bundle of user packages, flag constraints on those packages and a --- resolver, determine if the resolver fully, partially or fails to satisfy the --- dependencies of the user packages. --- --- If the package flags are passed as 'Nothing' then flags are chosen --- automatically. -checkResolverSpec - :: (StackM env m, HasConfig env, HasGHCVariant env) - => [C.GenericPackageDescription] - -> Maybe (Map PackageName (Map FlagName Bool)) - -> Resolver - -> m BuildPlanCheck -checkResolverSpec gpds flags resolver = do - case resolver of - ResolverSnapshot name -> checkSnapBuildPlan gpds flags name - ResolverCompiler {} -> return $ BuildPlanCheckPartial Map.empty Map.empty - -- TODO support custom resolver for stack init - ResolverCustom {} -> return $ BuildPlanCheckPartial Map.empty Map.empty + lpiConstraints lpi = (lpiVersion lpi, lpiFlags lpi) + lsConstraints ls = Map.union + (Map.map lpiConstraints (lsPackages ls)) + (Map.map lpiConstraints (lsGlobals ls)) --- | Finds all files with a .cabal extension under a given directory. If --- a `hpack` `package.yaml` file exists, this will be used to generate a cabal --- file. --- Subdirectories can be included depending on the @recurse@ parameter. -findCabalFiles :: (MonadIO m, MonadLogger m) => Bool -> Path Abs Dir -> m [Path Abs File] -findCabalFiles recurse dir = do - liftIO (findFiles dir isHpack subdirFilter) >>= mapM_ (hpack . parent) - liftIO (findFiles dir isCabal subdirFilter) +-- | Finds all directories with a .cabal file or an hpack +-- package.yaml. Subdirectories can be included depending on the +-- @recurse@ parameter. +findCabalDirs + :: (MonadIO m, MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m, HasConfig env) + => Bool -> Path Abs Dir -> m (Set (Path Abs Dir)) +findCabalDirs recurse dir = + (Set.fromList . map parent) + <$> liftIO (findFiles dir isHpackOrCabal subdirFilter) where subdirFilter subdir = recurse && not (isIgnored subdir) isHpack = (== "package.yaml") . toFilePath . filename isCabal = (".cabal" `isSuffixOf`) . toFilePath + isHpackOrCabal x = isHpack x || isCabal x isIgnored path = "." `isPrefixOf` dirName || dirName `Set.member` ignoredDirs where @@ -540,30 +530,31 @@ -- pairs as well as any filenames for duplicate packages not included in the -- pairs. cabalPackagesCheck - :: (StackM env m, HasConfig env, HasGHCVariant env) - => [Path Abs File] + :: (HasConfig env, HasGHCVariant env) + => [Path Abs Dir] -> String -> Maybe String - -> m ( Map PackageName (Path Abs File, C.GenericPackageDescription) + -> RIO env + ( Map PackageName (Path Abs File, C.GenericPackageDescription) , [Path Abs File]) -cabalPackagesCheck cabalfps noPkgMsg dupErrMsg = do - when (null cabalfps) $ +cabalPackagesCheck cabaldirs noPkgMsg dupErrMsg = do + when (null cabaldirs) $ error noPkgMsg - relpaths <- mapM prettyPath cabalfps - $logInfo $ "Using cabal packages:" - $logInfo $ T.pack (formatGroup relpaths) + relpaths <- mapM prettyPath cabaldirs + logInfo "Using cabal packages:" + logInfo $ T.pack (formatGroup relpaths) - (warnings, gpds) <- mapAndUnzipM readPackageUnresolved cabalfps - zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings + packages <- map (\(x, y) -> (y, x)) <$> + mapM (flip readPackageUnresolvedDir True) + cabaldirs -- package name cannot be empty or missing otherwise -- it will result in cabal solver failure. -- stack requires packages name to match the cabal file name -- Just the latter check is enough to cover both the cases - let packages = zip cabalfps gpds - normalizeString = T.unpack . T.normalize T.NFC . T.pack + let normalizeString = T.unpack . T.normalize T.NFC . T.pack getNameMismatchPkg (fp, gpd) | (normalizeString . show . gpdPackageName) gpd /= (normalizeString . FP.takeBaseName . toFilePath) fp = Just fp @@ -590,11 +581,11 @@ when (dupIgnored /= []) $ do dups <- mapM (mapM (prettyPath. fst)) (dupGroups packages) - $logWarn $ T.pack $ + logWarn $ T.pack $ "Following packages have duplicate package names:\n" <> intercalate "\n" (map formatGroup dups) case dupErrMsg of - Nothing -> $logWarn $ T.pack $ + Nothing -> logWarn $ T.pack $ "Packages with duplicate names will be ignored.\n" <> "Packages in upper level directories will be preferred.\n" Just msg -> error msg @@ -606,17 +597,21 @@ formatGroup :: [String] -> String formatGroup = concatMap (\path -> "- " <> path <> "\n") -reportMissingCabalFiles :: (MonadIO m, MonadThrow m, MonadLogger m) +reportMissingCabalFiles + :: (MonadIO m, MonadUnliftIO m, MonadThrow m, MonadLogger m, + HasRunner env, MonadReader env m, HasConfig env) => [Path Abs File] -- ^ Directories to scan -> Bool -- ^ Whether to scan sub-directories -> m () reportMissingCabalFiles cabalfps includeSubdirs = do - allCabalfps <- findCabalFiles includeSubdirs =<< getCurrentDir + allCabalDirs <- findCabalDirs includeSubdirs =<< getCurrentDir - relpaths <- mapM prettyPath (allCabalfps \\ cabalfps) + relpaths <- mapM prettyPath + $ Set.toList + $ allCabalDirs `Set.difference` Set.fromList (map parent cabalfps) unless (null relpaths) $ do - $logWarn $ "The following packages are missing from the config:" - $logWarn $ T.pack (formatGroup relpaths) + logWarn "The following packages are missing from the config:" + logWarn $ T.pack (formatGroup relpaths) -- TODO Currently solver uses a stack.yaml in the parent chain when there is -- no stack.yaml in the current directory. It should instead look for a @@ -628,35 +623,37 @@ -- dependencies in an existing stack.yaml and suggest changes in flags or -- extra dependencies so that the specified packages can be compiled. solveExtraDeps - :: (StackM env m, HasEnvConfig env) + :: HasEnvConfig env => Bool -- ^ modify stack.yaml? - -> m () + -> RIO env () solveExtraDeps modStackYaml = do bconfig <- view buildConfigL let stackYaml = bcStackYaml bconfig relStackYaml <- prettyPath stackYaml - $logInfo $ "Using configuration file: " <> T.pack relStackYaml - packages <- getLocalPackages - let cabalDirs = Map.keys packages - noPkgMsg = "No cabal packages found in " <> relStackYaml <> + logInfo $ "Using configuration file: " <> T.pack relStackYaml + lp <- getLocalPackages + let packages = lpProject lp + let noPkgMsg = "No cabal packages found in " <> relStackYaml <> ". Please add at least one directory containing a .cabal \ \file. You can also use 'stack init' to automatically \ \generate the config file." dupPkgFooter = "Please remove the directories containing duplicate \ \entries from '" <> relStackYaml <> "'." - cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs) + cabalDirs = map lpvRoot $ Map.elems packages + cabalfps = map lpvCabalFP $ Map.elems packages -- TODO when solver supports --ignore-subdirs option pass that as the -- second argument here. reportMissingCabalFiles cabalfps True - (bundle, _) <- cabalPackagesCheck cabalfps noPkgMsg (Just dupPkgFooter) + (bundle, _) <- cabalPackagesCheck cabalDirs noPkgMsg (Just dupPkgFooter) let gpds = Map.elems $ fmap snd bundle - oldFlags = unPackageFlags (bcFlags bconfig) - oldExtraVersions = bcExtraDeps bconfig - resolver = bcResolver bconfig + oldFlags = bcFlags bconfig + oldExtraVersions = Map.map (gpdVersion . fst) (lpDependencies lp) + sd = bcSnapshotDef bconfig + resolver = sdResolver sd oldSrcs = gpdPackages gpds oldSrcFlags = Map.intersection oldFlags oldSrcs oldExtraFlags = Map.intersection oldFlags oldExtraVersions @@ -664,19 +661,18 @@ srcConstraints = mergeConstraints oldSrcs oldSrcFlags extraConstraints = mergeConstraints oldExtraVersions oldExtraFlags - let resolver' = toResolverNotLoaded resolver - resolverResult <- checkResolverSpec gpds (Just oldSrcFlags) resolver' + resolverResult <- checkSnapBuildPlanActual (parent stackYaml) gpds (Just oldSrcFlags) sd resultSpecs <- case resolverResult of BuildPlanCheckOk flags -> return $ Just (mergeConstraints oldSrcs flags, Map.empty) BuildPlanCheckPartial {} -> do eres <- solveResolverSpec stackYaml cabalDirs - (resolver', srcConstraints, extraConstraints) + (sd, srcConstraints, extraConstraints) -- TODO Solver should also use the init code to ignore incompatible -- packages return $ either (const Nothing) Just eres BuildPlanCheckFail {} -> - throwM $ ResolverMismatch IsSolverCmd resolver (show resolverResult) + throwM $ ResolverMismatch IsSolverCmd (sdResolverName sd) (show resolverResult) (srcs, edeps) <- case resultSpecs of Nothing -> throwM (SolverGiveUp giveUpMsg) @@ -700,14 +696,14 @@ changed = any (not . Map.null) [newVersions, goneVersions] || any (not . Map.null) [newFlags, goneFlags] - || any (/= resolver') mOldResolver + || any (/= void resolver) (fmap void mOldResolver) if changed then do - $logInfo "" - $logInfo $ "The following changes will be made to " + logInfo "" + logInfo $ "The following changes will be made to " <> T.pack relStackYaml <> ":" - printResolver mOldResolver resolver' + printResolver (fmap void mOldResolver) (void resolver) printFlags newFlags "* Flags to be added" printDeps newVersions "* Dependencies to be added" @@ -718,12 +714,12 @@ -- TODO backup the old config file if modStackYaml then do writeStackYaml stackYaml resolver versions flags - $logInfo $ "Updated " <> T.pack relStackYaml + logInfo $ "Updated " <> T.pack relStackYaml else do - $logInfo $ "To automatically update " <> T.pack relStackYaml + logInfo $ "To automatically update " <> T.pack relStackYaml <> ", rerun with '--update-config'" else - $logInfo $ "No changes needed to " <> T.pack relStackYaml + logInfo $ "No changes needed to " <> T.pack relStackYaml where indentLines t = T.unlines $ fmap (" " <>) (T.lines t) @@ -731,23 +727,23 @@ printResolver mOldRes res = do forM_ mOldRes $ \oldRes -> when (res /= oldRes) $ do - $logInfo $ T.concat + logInfo $ T.concat [ "* Resolver changes from " - , resolverName oldRes + , resolverRawName oldRes , " to " - , resolverName res + , resolverRawName res ] printFlags fl msg = do unless (Map.null fl) $ do - $logInfo $ T.pack msg - $logInfo $ indentLines $ decodeUtf8 $ Yaml.encode + logInfo $ T.pack msg + logInfo $ indentLines $ decodeUtf8 $ Yaml.encode $ object ["flags" .= fl] printDeps deps msg = do unless (Map.null deps) $ do - $logInfo $ T.pack msg - $logInfo $ indentLines $ decodeUtf8 $ Yaml.encode $ object + logInfo $ T.pack msg + logInfo $ indentLines $ decodeUtf8 $ Yaml.encode $ object ["extra-deps" .= map fromTuple (Map.toList deps)] writeStackYaml path res deps fl = do @@ -759,7 +755,7 @@ HashMap.insert "extra-deps" (toJSON $ map fromTuple $ Map.toList deps) $ HashMap.insert ("flags" :: Text) (toJSON fl) - $ HashMap.insert ("resolver" :: Text) (toJSON (resolverName res)) obj + $ HashMap.insert ("resolver" :: Text) (toJSON res) obj liftIO $ Yaml.encodeFile fp obj' giveUpMsg = concat @@ -771,11 +767,36 @@ , " - Adjust resolver.\n" ] +-- | Same as 'checkSnapBuildPLan', but set up a real GHC if needed. +-- +-- If we're using a Stackage snapshot, we can use the snapshot hints +-- to determine global library information. This will not be available +-- for custom and GHC resolvers, however. Therefore, we insist that it +-- be installed first. Fortunately, the standard `stack solver` +-- behavior only chooses Stackage snapshots, so the common case will +-- not force the installation of a bunch of GHC versions. +checkSnapBuildPlanActual + :: (HasConfig env, HasGHCVariant env) + => Path Abs Dir -- ^ project root, used for checking out necessary files + -> [C.GenericPackageDescription] + -> Maybe (Map PackageName (Map FlagName Bool)) + -> SnapshotDef + -> RIO env BuildPlanCheck +checkSnapBuildPlanActual root gpds flags sd = do + let forNonSnapshot inner = setupCabalEnv (sdWantedCompilerVersion sd) (inner . Just) + runner = + case sdResolver sd of + ResolverSnapshot _ -> ($ Nothing) + ResolverCompiler _ -> forNonSnapshot + ResolverCustom _ _ -> forNonSnapshot + + runner $ checkSnapBuildPlan root gpds flags sd + prettyPath :: forall r t m. (MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t)) => Path r t -> m String prettyPath path = do eres <- liftIO $ try $ makeRelativeToCurrentDir path return $ case eres of - Left (_ :: PathParseException) -> toFilePath path + Left (_ :: PathException) -> toFilePath path Right res -> toFilePath (res :: Path Rel t) diff --git a/src/Stack/StaticBytes.hs b/src/Stack/StaticBytes.hs new file mode 100644 --- /dev/null +++ b/src/Stack/StaticBytes.hs @@ -0,0 +1,235 @@ +-- This module can (and perhaps should) be separate into its own +-- package, it's generally useful. +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Stack.StaticBytes + ( Bytes8 + , Bytes16 + , Bytes32 + , Bytes64 + , Bytes128 + , DynamicBytes + , StaticBytes + , StaticBytesException (..) + , toStaticExact + , toStaticPad + , toStaticTruncate + , toStaticPadTruncate + , fromStatic + ) where + +import Stack.Prelude hiding (words) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Base as VU +import qualified Data.Vector.Storable as VS +import System.IO.Unsafe (unsafePerformIO) +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Storable +import Data.Bits +import qualified Data.Primitive.ByteArray as BA +import Data.ByteArray + +newtype Bytes8 = Bytes8 Word64 + deriving (Eq, Ord, Generic, NFData, Hashable, Data, Store) +instance Show Bytes8 where -- FIXME good enough? + show (Bytes8 w) = show (fromWordsD 8 [w] :: B.ByteString) +data Bytes16 = Bytes16 !Bytes8 !Bytes8 + deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data, Store) +data Bytes32 = Bytes32 !Bytes16 !Bytes16 + deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data, Store) +data Bytes64 = Bytes64 !Bytes32 !Bytes32 + deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data, Store) +data Bytes128 = Bytes128 !Bytes64 !Bytes64 + deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data, Store) + +data StaticBytesException + = NotEnoughBytes + | TooManyBytes + deriving (Show, Eq, Typeable) +instance Exception StaticBytesException + +-- All lengths below are given in bytes + +class DynamicBytes dbytes where + lengthD :: dbytes -> Int + -- | Yeah, it looks terrible to use a list here, but fusion should + -- kick in + withPeekD :: dbytes -> ((Int -> IO Word64) -> IO a) -> IO a + -- | May throw a runtime exception if invariants are violated! + fromWordsD :: Int -> [Word64] -> dbytes + +fromWordsForeign + :: (ForeignPtr a -> Int -> b) + -> Int + -> [Word64] + -> b +fromWordsForeign wrapper len words0 = unsafePerformIO $ do + fptr <- B.mallocByteString len + withForeignPtr fptr $ \ptr -> do + let loop _ [] = return () + loop off (w:ws) = do + pokeElemOff (castPtr ptr) off w + loop (off + 1) ws + loop 0 words0 + return $ wrapper fptr len + +withPeekForeign + :: (ForeignPtr a, Int, Int) + -> ((Int -> IO Word64) -> IO b) + -> IO b +withPeekForeign (fptr, off, len) inner = + withForeignPtr fptr $ \ptr -> do + let f off' + | off' >= len = return 0 + | off' + 8 > len = do + let loop w64 i + | off' + i >= len = return w64 + | otherwise = do + w8 :: Word8 <- peekByteOff ptr (off + off' + i) + let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64 + loop w64' (i + 1) + loop 0 0 + | otherwise = peekByteOff ptr (off + off') + inner f + +instance DynamicBytes B.ByteString where + lengthD = B.length + fromWordsD = fromWordsForeign (\fptr len -> B.fromForeignPtr fptr 0 len) + withPeekD = withPeekForeign . B.toForeignPtr + +instance word8 ~ Word8 => DynamicBytes (VS.Vector word8) where + lengthD = VS.length + fromWordsD = fromWordsForeign VS.unsafeFromForeignPtr0 + withPeekD = withPeekForeign . VS.unsafeToForeignPtr + +instance word8 ~ Word8 => DynamicBytes (VP.Vector word8) where + lengthD = VP.length + fromWordsD len words0 = unsafePerformIO $ do + ba <- BA.newByteArray len + let loop _ [] = do + ba' <- BA.unsafeFreezeByteArray ba + return $ VP.Vector 0 len ba' + loop i (w:ws) = do + BA.writeByteArray ba i w + loop (i + 1) ws + loop 0 words0 + withPeekD (VP.Vector off len ba) inner = do + let f off' + | off' >= len = return 0 + | off' + 8 > len = do + let loop w64 i + | off' + i >= len = return w64 + | otherwise = do + let w8 :: Word8 = BA.indexByteArray ba (off + off' + i) + let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64 + loop w64' (i + 1) + loop 0 0 + | otherwise = return $ BA.indexByteArray ba (off + (off' `div` 8)) + inner f + +instance word8 ~ Word8 => DynamicBytes (VU.Vector word8) where + lengthD = VU.length + fromWordsD len words = VU.V_Word8 (fromWordsD len words) + withPeekD (VU.V_Word8 v) = withPeekD v + +class StaticBytes sbytes where + lengthS :: proxy sbytes -> Int -- use type level literals instead? + -- difference list + toWordsS :: sbytes -> [Word64] -> [Word64] + usePeekS :: Int -> (Int -> IO Word64) -> IO sbytes + +instance StaticBytes Bytes8 where + lengthS _ = 8 + toWordsS (Bytes8 w) = (w:) + usePeekS off f = Bytes8 <$> f off + +instance StaticBytes Bytes16 where + lengthS _ = 16 + toWordsS (Bytes16 b1 b2) = toWordsS b1 . toWordsS b2 + usePeekS off f = Bytes16 <$> usePeekS off f <*> usePeekS (off + 8) f + +instance StaticBytes Bytes32 where + lengthS _ = 32 + toWordsS (Bytes32 b1 b2) = toWordsS b1 . toWordsS b2 + usePeekS off f = Bytes32 <$> usePeekS off f <*> usePeekS (off + 16) f + +instance StaticBytes Bytes64 where + lengthS _ = 64 + toWordsS (Bytes64 b1 b2) = toWordsS b1 . toWordsS b2 + usePeekS off f = Bytes64 <$> usePeekS off f <*> usePeekS (off + 32) f + +instance StaticBytes Bytes128 where + lengthS _ = 128 + toWordsS (Bytes128 b1 b2) = toWordsS b1 . toWordsS b2 + usePeekS off f = Bytes128 <$> usePeekS off f <*> usePeekS (off + 64) f + +instance ByteArrayAccess Bytes8 where + length _ = 8 + withByteArray = withByteArrayS +instance ByteArrayAccess Bytes16 where + length _ = 16 + withByteArray = withByteArrayS +instance ByteArrayAccess Bytes32 where + length _ = 32 + withByteArray = withByteArrayS +instance ByteArrayAccess Bytes64 where + length _ = 64 + withByteArray = withByteArrayS +instance ByteArrayAccess Bytes128 where + length _ = 128 + withByteArray = withByteArrayS + +withByteArrayS :: StaticBytes sbytes => sbytes -> (Ptr p -> IO a) -> IO a +withByteArrayS sbytes = withByteArray (fromStatic sbytes :: ByteString) + +toStaticExact + :: forall dbytes sbytes. + (DynamicBytes dbytes, StaticBytes sbytes) + => dbytes + -> Either StaticBytesException sbytes +toStaticExact dbytes = + case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of + LT -> Left NotEnoughBytes + GT -> Left TooManyBytes + EQ -> Right (toStaticPadTruncate dbytes) + +toStaticPad + :: forall dbytes sbytes. + (DynamicBytes dbytes, StaticBytes sbytes) + => dbytes + -> Either StaticBytesException sbytes +toStaticPad dbytes = + case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of + GT -> Left TooManyBytes + _ -> Right (toStaticPadTruncate dbytes) + +toStaticTruncate + :: forall dbytes sbytes. + (DynamicBytes dbytes, StaticBytes sbytes) + => dbytes + -> Either StaticBytesException sbytes +toStaticTruncate dbytes = + case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of + LT -> Left NotEnoughBytes + _ -> Right (toStaticPadTruncate dbytes) + +toStaticPadTruncate + :: (DynamicBytes dbytes, StaticBytes sbytes) + => dbytes + -> sbytes +toStaticPadTruncate dbytes = unsafePerformIO (withPeekD dbytes (usePeekS 0)) + +fromStatic + :: forall dbytes sbytes. + (DynamicBytes dbytes, StaticBytes sbytes) + => sbytes + -> dbytes +fromStatic = fromWordsD (lengthS (Nothing :: Maybe sbytes)) . ($ []) . toWordsS diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -16,7 +17,8 @@ ,ModTime ,modTime ,Installed(..) - ,PackageInstallInfo(..) + ,piiVersion + ,piiLocation ,Task(..) ,taskIsTarget ,taskLocation @@ -30,6 +32,7 @@ ,BuildSubset(..) ,defaultBuildOpts ,TaskType(..) + ,ttPackageLocation ,TaskConfigOpts(..) ,BuildCache(..) ,buildCacheVC @@ -46,26 +49,14 @@ ,precompiledCacheVC) where -import Control.DeepSeq -import Control.Exception -import Data.Binary (Binary) -import Data.Binary.Tagged (HasSemanticVersion, - HasStructuralInfo) +import Stack.Prelude import qualified Data.ByteString as S import Data.Char (isSpace) -import Data.Data -import Data.Hashable import Data.List.Extra import qualified Data.Map as Map -import Data.Map.Strict (Map) -import Data.Maybe -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as Set -import Data.Store.Internal (Store) import Data.Store.Version import Data.Store.VersionTagged -import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) @@ -75,15 +66,11 @@ import Distribution.PackageDescription (TestSuiteInterface) import Distribution.System (Arch) import qualified Distribution.Text as C -import GHC.Generics (Generic) -import Path (Abs, Dir, File, Path, - mkRelDir, parseRelDir, - toFilePath, ()) +import Path (mkRelDir, parseRelDir, ()) import Path.Extra (toFilePathNoTrailingSep) import Paths_stack as Meta -import Prelude import Stack.Constants -import Stack.Types.BuildPlan (GitSHA1) +import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Config @@ -102,8 +89,8 @@ data StackBuildException = Couldn'tFindPkgId PackageName | CompilerVersionMismatch - (Maybe (CompilerVersion, Arch)) -- found - (CompilerVersion, Arch) -- expected + (Maybe (CompilerVersion 'CVActual, Arch)) -- found + (CompilerVersion 'CVWanted, Arch) -- expected GHCVariant -- expected CompilerBuild -- expected VersionCheck @@ -124,6 +111,13 @@ [String] -- cabal arguments (Maybe (Path Abs File)) -- logfiles location [Text] -- log contents + | SetupHsBuildFailure + ExitCode + (Maybe PackageIdentifier) -- which package's custom setup, is simple setup if Nothing + (Path Abs File) -- ghc Executable + [String] -- ghc arguments + (Maybe (Path Abs File)) -- logfiles location + [Text] -- log contents | ExecutionFailure [SomeException] | LocalPackageDoesn'tMatchTarget PackageName @@ -132,7 +126,6 @@ | NoSetupHsFound (Path Abs Dir) | InvalidFlagSpecification (Set UnusedFlags) | TargetParseException [Text] - | DuplicateLocalPackageNames [(PackageName, [Path Abs Dir])] | SolverGiveUp String | SolverMissingCabalInstall | SomeTargetsNotBuildable [(PackageName, NamedComponent)] @@ -234,23 +227,9 @@ "Unsupported test suite type: " <> show interface -- Supressing duplicate output show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) = - let fullCmd = unwords - $ dropQuotes (toFilePath execName) - : map (T.unpack . showProcessArgDebug) fullArgs - logLocations = maybe "" (\fp -> "\n Logs have been written to: " ++ toFilePath fp) logFiles - in "\n-- While building package " ++ dropQuotes (show taskProvides') ++ " using:\n" ++ - " " ++ fullCmd ++ "\n" ++ - " Process exited with code: " ++ show exitCode ++ - (if exitCode == ExitFailure (-9) - then " (THIS MAY INDICATE OUT OF MEMORY)" - else "") ++ - logLocations ++ - (if null bss - then "" - else "\n\n" ++ doubleIndent (map T.unpack bss)) - where - doubleIndent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) - dropQuotes = filter ('\"' /=) + showBuildError False exitCode (Just taskProvides') execName fullArgs logFiles bss + show (SetupHsBuildFailure exitCode mtaskProvides execName fullArgs logFiles bss) = + showBuildError True exitCode mtaskProvides execName fullArgs logFiles bss show (ExecutionFailure es) = intercalate "\n\n" $ map show es show (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat [ "Version for local package " @@ -304,15 +283,6 @@ $ "The following errors occurred while parsing the build targets:" : map (("- " ++) . T.unpack) errs - show (DuplicateLocalPackageNames pairs) = concat - $ "The same package name is used in multiple local packages\n" - : map go pairs - where - go (name, dirs) = unlines - $ "" - : (packageNameString name ++ " used in:") - : map goDir dirs - goDir dir = "- " ++ toFilePath dir show (SolverGiveUp msg) = concat [ "\nSolver could not resolve package dependencies.\n" , "You can try the following:\n" @@ -356,10 +326,45 @@ where possibleCauses = "No module named \"Main\". The 'main-is' source file should usually have a header indicating that it's a 'Main' module." : + "A cabal file that refers to nonexistent other files (e.g. a license-file that doesn't exist). Running 'cabal check' may point out these issues." : if isSimpleBuildType then [] else ["The Setup.hs file is changing the installation target dir."] +showBuildError + :: Bool + -> ExitCode + -> Maybe PackageIdentifier + -> Path Abs File + -> [String] + -> Maybe (Path Abs File) + -> [Text] + -> String +showBuildError isBuildingSetup exitCode mtaskProvides execName fullArgs logFiles bss = + let fullCmd = unwords + $ dropQuotes (toFilePath execName) + : map (T.unpack . showProcessArgDebug) fullArgs + logLocations = maybe "" (\fp -> "\n Logs have been written to: " ++ toFilePath fp) logFiles + in "\n-- While building " ++ + (case (isBuildingSetup, mtaskProvides) of + (False, Nothing) -> error "Invariant violated: unexpected case in showBuildError" + (False, Just taskProvides') -> "package " ++ dropQuotes (show taskProvides') + (True, Nothing) -> "simple Setup.hs" + (True, Just taskProvides') -> "custom Setup.hs for package " ++ dropQuotes (show taskProvides') + ) ++ + " using:\n " ++ fullCmd ++ "\n" ++ + " Process exited with code: " ++ show exitCode ++ + (if exitCode == ExitFailure (-9) + then " (THIS MAY INDICATE OUT OF MEMORY)" + else "") ++ + logLocations ++ + (if null bss + then "" + else "\n\n" ++ doubleIndent (map T.unpack bss)) + where + doubleIndent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) + dropQuotes = filter ('\"' /=) + instance Exception StackBuildException ---------------------------------------------- @@ -408,15 +413,15 @@ instance NFData CachePkgSrc toCachePkgSrc :: PackageSource -> CachePkgSrc -toCachePkgSrc (PSLocal lp) = CacheSrcLocal (toFilePath (lpDir lp)) -toCachePkgSrc PSUpstream{} = CacheSrcUpstream +toCachePkgSrc (PSFiles lp _) = CacheSrcLocal (toFilePath (lpDir lp)) +toCachePkgSrc PSIndex{} = CacheSrcUpstream configCacheVC :: VersionConfig ConfigCache configCacheVC = storeVersionConfig "config-v3" "z7N_NxX7Gbz41Gi9AGEa1zoLE-4=" -- | A task to perform when building data Task = Task - { taskProvides :: !PackageIdentifier + { taskProvides :: !PackageIdentifier -- FIXME turn this into a function on taskType? -- ^ the package/version to be built , taskType :: !TaskType -- ^ the task type, telling us how to build this @@ -426,6 +431,20 @@ , taskAllInOne :: !Bool -- ^ indicates that the package can be built in one step , taskCachePkgSrc :: !CachePkgSrc + , taskAnyMissing :: !Bool + -- ^ Were any of the dependencies missing? The reason this is + -- necessary is... hairy. And as you may expect, a bug in + -- Cabal. See: + -- . The + -- problem is that Cabal may end up generating the same package ID + -- for a dependency, even if the ABI has changed. As a result, + -- without this field, Stack would think that a reconfigure is + -- unnecessary, when in fact we _do_ need to reconfigure. The + -- details here suck. We really need proper hashes for package + -- identifiers. + , taskBuildTypeConfig :: !Bool + -- ^ Is the build type of this package Configure. Check out + -- ensureConfigureScript in Stack.Build.Execute for the motivation } deriving Show @@ -446,21 +465,25 @@ -- | The type of a task, either building local code or something from the -- package index (upstream) -data TaskType = TTLocal LocalPackage - | TTUpstream Package InstallLocation (Maybe GitSHA1) +data TaskType = TTFiles LocalPackage InstallLocation + | TTIndex Package InstallLocation PackageIdentifierRevision -- FIXME major overhaul for PackageLocation? deriving Show +ttPackageLocation :: TaskType -> PackageLocationIndex FilePath +ttPackageLocation (TTFiles lp _) = PLOther (lpLocation lp) +ttPackageLocation (TTIndex _ _ pir) = PLIndex pir + taskIsTarget :: Task -> Bool taskIsTarget t = case taskType t of - TTLocal lp -> lpWanted lp + TTFiles lp _ -> lpWanted lp _ -> False taskLocation :: Task -> InstallLocation taskLocation task = case taskType task of - TTLocal _ -> Local - TTUpstream _ loc _ -> loc + TTFiles _ loc -> loc + TTIndex _ loc _ -> loc -- | A complete plan of what needs to be built and how to do it data Plan = Plan @@ -583,6 +606,7 @@ , map ("--extra-include-dirs=" ++) (Set.toList (configExtraIncludeDirs config)) , map ("--extra-lib-dirs=" ++) (Set.toList (configExtraLibDirs config)) , maybe [] (\customGcc -> ["--with-gcc=" ++ toFilePath customGcc]) (configOverrideGccPath config) + , hpackOptions (configOverrideHpack config) , ["--ghcjs" | wc == Ghcjs] , ["--exact-configuration" | useExactConf] ] @@ -607,6 +631,9 @@ where toDepOption = if newerCabal then toDepOption1_22 else toDepOption1_18 + hpackOptions HpackBundled = [] + hpackOptions (HpackCommand cmd) = ["--with-hpack=" ++ cmd] + toDepOption1_22 ident gid = concat [ "--dependency=" , packageNameString $ packageIdentifierName ident @@ -658,9 +685,6 @@ -- ^ Full paths to executables } deriving (Show, Eq, Generic, Data, Typeable) -instance Binary PrecompiledCache -instance HasSemanticVersion PrecompiledCache -instance HasStructuralInfo PrecompiledCache instance Store PrecompiledCache instance NFData PrecompiledCache diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -1,487 +1,382 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} - -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} -- | Shared types for various stackage packages. module Stack.Types.BuildPlan ( -- * Types - BuildPlan (..) - , PackagePlan (..) - , PackageConstraints (..) - , TestState (..) - , SystemInfo (..) - , Maintainer (..) + SnapshotDef (..) + , snapshotDefVC + , sdRawPathName + , PackageLocation (..) + , PackageLocationIndex (..) + , RepoType (..) + , Subdirs (..) + , Repo (..) + , Archive (..) , ExeName (..) - , SimpleDesc (..) - , Snapshots (..) - , DepInfo (..) - , Component (..) - , SnapName (..) - , MiniBuildPlan (..) - , miniBuildPlanVC - , MiniPackageInfo (..) - , CabalFileInfo (..) - , GitSHA1 (..) - , renderSnapName - , parseSnapName - , SnapshotHash (..) - , trimmedSnapshotHash + , LoadedSnapshot (..) + , loadedSnapshotVC + , LoadedPackageInfo (..) , ModuleName (..) + , fromCabalModuleName , ModuleInfo (..) , moduleInfoVC + , setCompilerVersion + , sdWantedCompilerVersion ) where -import Control.Applicative -import Control.Arrow ((&&&)) -import Control.DeepSeq (NFData) -import Control.Exception (Exception) -import Control.Monad.Catch (MonadThrow, throwM) -import Data.Aeson (FromJSON (..), FromJSONKey(..), ToJSON (..), ToJSONKey (..), object, withObject, withText, (.!=), (.:), (.:?), (.=)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Data -import qualified Data.HashMap.Strict as HashMap -import Data.Hashable (Hashable) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.Map (Map) +import Data.Aeson (ToJSON (..), FromJSON (..), withText, object, (.=)) +import Data.Aeson.Extended (WithJSONWarnings (..), (..:), (..:?), withObjectWarnings, noJSONWarnings, (..!=)) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Monoid -import Data.Set (Set) -import Data.Store (Store) +import qualified Data.Set as Set import Data.Store.Version import Data.Store.VersionTagged -import Data.String (IsString, fromString) -import Data.Text (Text, pack, unpack) import qualified Data.Text as T -import Data.Text.Read (decimal) -import Data.Time (Day) -import qualified Data.Traversable as T -import Data.Vector (Vector) -import Distribution.System (Arch, OS (..)) -import qualified Distribution.Text as DT +import Data.Text.Encoding (encodeUtf8) +import qualified Distribution.ModuleName as C import qualified Distribution.Version as C -import GHC.Generics (Generic) -import Prelude -- Fix AMP warning -import Safe (readMay) +import Network.HTTP.Client (parseRequest) +import Stack.Prelude import Stack.Types.Compiler import Stack.Types.FlagName +import Stack.Types.GhcPkgId +import Stack.Types.PackageIdentifier import Stack.Types.PackageName +import Stack.Types.Resolver import Stack.Types.Version - --- | The name of an LTS Haskell or Stackage Nightly snapshot. -data SnapName - = LTS !Int !Int - | Nightly !Day - deriving (Show, Eq, Ord) +import Stack.Types.VersionIntervals -data BuildPlan = BuildPlan - { bpSystemInfo :: SystemInfo - , bpTools :: Vector (PackageName, Version) - , bpPackages :: Map PackageName PackagePlan - , bpGithubUsers :: Map Text (Set Text) +-- | A definition of a snapshot. This could be a Stackage snapshot or +-- something custom. It does not include information on the global +-- package database, this is added later. +-- +-- It may seem more logic to attach flags, options, etc, directly with +-- the desired package. However, this isn't possible yet: our +-- definition may contain tarballs or Git repos, and we don't actually +-- know the package names contained there. Therefore, we capture all +-- of this additional information by package name, and later in the +-- snapshot load step we will resolve the contents of tarballs and +-- repos, figure out package names, and assigned values appropriately. +data SnapshotDef = SnapshotDef + { sdParent :: !(Either (CompilerVersion 'CVWanted) SnapshotDef) + -- ^ The snapshot to extend from. This is either a specific + -- compiler, or a @SnapshotDef@ which gives us more information + -- (like packages). Ultimately, we'll end up with a + -- @CompilerVersion@. + , sdResolver :: !LoadedResolver + -- ^ The resolver that provides this definition. + , sdResolverName :: !Text + -- ^ A user-friendly way of referring to this resolver. + , sdLocations :: ![PackageLocationIndex Subdirs] + -- ^ Where to grab all of the packages from. + , sdDropPackages :: !(Set PackageName) + -- ^ Packages present in the parent which should not be included + -- here. + , sdFlags :: !(Map PackageName (Map FlagName Bool)) + -- ^ Flag values to override from the defaults + , sdHidden :: !(Map PackageName Bool) + -- ^ Packages which should be hidden when registering. This will + -- affect, for example, the import parser in the script + -- command. We use a 'Map' instead of just a 'Set' to allow + -- overriding the hidden settings in a parent snapshot. + , sdGhcOptions :: !(Map PackageName [Text]) + -- ^ GHC options per package + , sdGlobalHints :: !(Map PackageName (Maybe Version)) + -- ^ Hints about which packages are available globally. When + -- actually building code, we trust the package database provided + -- by GHC itself, since it may be different based on platform or + -- GHC install. However, when we want to check the compatibility + -- of a snapshot with some codebase without installing GHC (e.g., + -- during stack init), we would use this field. } - deriving (Show, Eq) - -instance ToJSON BuildPlan where - toJSON BuildPlan {..} = object - [ "system-info" .= bpSystemInfo - , "tools" .= fmap goTool bpTools - , "packages" .= bpPackages - , "github-users" .= bpGithubUsers - ] - where - goTool (k, v) = object - [ "name" .= k - , "version" .= v - ] -instance FromJSON BuildPlan where - parseJSON = withObject "BuildPlan" $ \o -> do - bpSystemInfo <- o .: "system-info" - bpTools <- o .: "tools" >>= T.mapM goTool - bpPackages <- o .: "packages" - bpGithubUsers <- o .:? "github-users" .!= mempty - return BuildPlan {..} - where - goTool = withObject "Tool" $ \o -> (,) - <$> o .: "name" - <*> o .: "version" + deriving (Show, Eq, Data, Generic, Typeable) +instance Store SnapshotDef +instance NFData SnapshotDef -data PackagePlan = PackagePlan - { ppVersion :: Version - , ppCabalFileInfo :: Maybe CabalFileInfo - , ppGithubPings :: Set Text - , ppUsers :: Set PackageName - , ppConstraints :: PackageConstraints - , ppDesc :: SimpleDesc - } - deriving (Show, Eq) +snapshotDefVC :: VersionConfig SnapshotDef +snapshotDefVC = storeVersionConfig "sd-v1" "tnwWSSLerZ2XeR6XpVwj5Uh0eF4=" -instance ToJSON PackagePlan where - toJSON PackagePlan {..} = object - $ maybe id (\cfi -> (("cabal-file-info" .= cfi):)) ppCabalFileInfo - [ "version" .= ppVersion - , "github-pings" .= ppGithubPings - , "users" .= ppUsers - , "constraints" .= ppConstraints - , "description" .= ppDesc - ] -instance FromJSON PackagePlan where - parseJSON = withObject "PackageBuild" $ \o -> do - ppVersion <- o .: "version" - ppCabalFileInfo <- o .:? "cabal-file-info" - ppGithubPings <- o .:? "github-pings" .!= mempty - ppUsers <- o .:? "users" .!= mempty - ppConstraints <- o .: "constraints" - ppDesc <- o .: "description" - return PackagePlan {..} +-- | A relative file path including a unique string for the given +-- snapshot. +sdRawPathName :: SnapshotDef -> String +sdRawPathName sd = + T.unpack $ go $ sdResolver sd + where + go (ResolverSnapshot name) = renderSnapName name + go (ResolverCompiler version) = compilerVersionText version + go (ResolverCustom _ hash) = "custom-" <> sdResolverName sd <> "-" <> trimmedSnapshotHash hash --- | Information on the contents of a cabal file -data CabalFileInfo = CabalFileInfo - { cfiSize :: !Int - -- ^ File size in bytes - , cfiHashes :: !(Map.Map Text Text) - -- ^ Various hashes of the file contents - } - deriving (Show, Eq, Generic) -instance ToJSON CabalFileInfo where - toJSON CabalFileInfo {..} = object - [ "size" .= cfiSize - , "hashes" .= cfiHashes - ] -instance FromJSON CabalFileInfo where - parseJSON = withObject "CabalFileInfo" $ \o -> do - cfiSize <- o .: "size" - cfiHashes <- o .: "hashes" - return CabalFileInfo {..} +-- | Modify the wanted compiler version in this snapshot. This is used +-- when overriding via the `compiler` value in a custom snapshot or +-- stack.yaml file. We do _not_ need to modify the snapshot's hash for +-- this: all binary caches of a snapshot are stored in a filepath that +-- encodes the actual compiler version in addition to the +-- hash. Therefore, modifications here will not lead to any invalid +-- data. +setCompilerVersion :: CompilerVersion 'CVWanted -> SnapshotDef -> SnapshotDef +setCompilerVersion cv = + go + where + go sd = + case sdParent sd of + Left _ -> sd { sdParent = Left cv } + Right sd' -> sd { sdParent = Right $ go sd' } -display :: DT.Text a => a -> Text -display = fromString . DT.display +-- | Where to get the contents of a package (including cabal file +-- revisions) from. +-- +-- A GADT may be more logical than the index parameter, but this plays +-- more nicely with Generic deriving. +data PackageLocation subdirs + = PLFilePath !FilePath + -- ^ Note that we use @FilePath@ and not @Path@s. The goal is: first parse + -- the value raw, and then use @canonicalizePath@ and @parseAbsDir@. + | PLArchive !(Archive subdirs) + | PLRepo !(Repo subdirs) + -- ^ Stored in a source control repository + deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor) +instance (Store a) => Store (PackageLocation a) +instance (NFData a) => NFData (PackageLocation a) -simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a -simpleParse orig = withTypeRep $ \rep -> - case DT.simpleParse str of - Nothing -> throwM (ParseFailedException rep (pack str)) - Just v -> return v - where - str = unpack orig +-- | Add in the possibility of getting packages from the index +-- (including cabal file revisions). We have special handling of this +-- case in many places in the codebase, and therefore represent it +-- with a separate data type from 'PackageLocation'. +data PackageLocationIndex subdirs + = PLIndex !PackageIdentifierRevision + -- ^ Grab the package from the package index with the given + -- version and (optional) cabal file info to specify the correct + -- revision. + | PLOther !(PackageLocation subdirs) + deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor) +instance (Store a) => Store (PackageLocationIndex a) +instance (NFData a) => NFData (PackageLocationIndex a) - withTypeRep :: Typeable a => (TypeRep -> m a) -> m a - withTypeRep f = - res - where - res = f (typeOf (unwrap res)) +-- | A package archive, could be from a URL or a local file +-- path. Local file path archives are assumed to be unchanging +-- over time, and so are allowed in custom snapshots. +data Archive subdirs = Archive + { archiveUrl :: !Text + , archiveSubdirs :: !subdirs + , archiveHash :: !(Maybe StaticSHA256) + } + deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor) +instance Store a => Store (Archive a) +instance NFData a => NFData (Archive a) - unwrap :: m a -> a - unwrap _ = error "unwrap" +-- | The type of a source control repository. +data RepoType = RepoGit | RepoHg + deriving (Generic, Show, Eq, Ord, Data, Typeable) +instance Store RepoType +instance NFData RepoType -data BuildPlanTypesException - = ParseSnapNameException Text - | ParseFailedException TypeRep Text - deriving Typeable -instance Exception BuildPlanTypesException -instance Show BuildPlanTypesException where - show (ParseSnapNameException t) = "Invalid snapshot name: " ++ T.unpack t - show (ParseFailedException rep t) = - "Unable to parse " ++ show t ++ " as " ++ show rep +data Subdirs + = DefaultSubdirs + | ExplicitSubdirs ![FilePath] + deriving (Generic, Show, Eq, Data, Typeable) +instance Store Subdirs +instance NFData Subdirs +instance FromJSON Subdirs where + parseJSON = fmap ExplicitSubdirs . parseJSON -data PackageConstraints = PackageConstraints - { pcVersionRange :: VersionRange - , pcMaintainer :: Maybe Maintainer - , pcTests :: TestState - , pcHaddocks :: TestState - , pcBuildBenchmarks :: Bool - , pcFlagOverrides :: Map FlagName Bool - , pcEnableLibProfile :: Bool - , pcHide :: Bool +-- | Information on packages stored in a source control repository. +data Repo subdirs = Repo + { repoUrl :: !Text + , repoCommit :: !Text + , repoType :: !RepoType + , repoSubdirs :: !subdirs } - deriving (Show, Eq) -instance ToJSON PackageConstraints where - toJSON PackageConstraints {..} = object $ addMaintainer - [ "version-range" .= display pcVersionRange - , "tests" .= pcTests - , "haddocks" .= pcHaddocks - , "build-benchmarks" .= pcBuildBenchmarks - , "flags" .= pcFlagOverrides - , "library-profiling" .= pcEnableLibProfile - , "hide" .= pcHide + deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor) +instance Store a => Store (Repo a) +instance NFData a => NFData (Repo a) + +instance subdirs ~ Subdirs => ToJSON (PackageLocationIndex subdirs) where + toJSON (PLIndex ident) = toJSON ident + toJSON (PLOther loc) = toJSON loc + +instance subdirs ~ Subdirs => ToJSON (PackageLocation subdirs) where + toJSON (PLFilePath fp) = toJSON fp + toJSON (PLArchive (Archive t DefaultSubdirs Nothing)) = toJSON t + toJSON (PLArchive (Archive t subdirs msha)) = object $ concat + [ ["location" .= t] + , case subdirs of + DefaultSubdirs -> [] + ExplicitSubdirs x -> ["subdirs" .= x] + , case msha of + Nothing -> [] + Just sha -> ["sha256" .= staticSHA256ToText sha] ] + toJSON (PLRepo (Repo url commit typ subdirs)) = object $ concat + [ case subdirs of + DefaultSubdirs -> [] + ExplicitSubdirs x -> ["subdirs" .= x] + , [urlKey .= url] + , ["commit" .= commit] + ] where - addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer -instance FromJSON PackageConstraints where - parseJSON = withObject "PackageConstraints" $ \o -> do - pcVersionRange <- (o .: "version-range") - >>= either (fail . show) return . simpleParse - pcTests <- o .: "tests" - pcHaddocks <- o .: "haddocks" - pcBuildBenchmarks <- o .: "build-benchmarks" - pcFlagOverrides <- o .: "flags" - pcMaintainer <- o .:? "maintainer" - pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling") - pcHide <- o .:? "hide" .!= False - return PackageConstraints {..} - -data TestState = ExpectSuccess - | ExpectFailure - | Don'tBuild -- ^ when the test suite will pull in things we don't want - deriving (Show, Eq, Ord, Bounded, Enum) + urlKey = + case typ of + RepoGit -> "git" + RepoHg -> "hg" -testStateToText :: TestState -> Text -testStateToText ExpectSuccess = "expect-success" -testStateToText ExpectFailure = "expect-failure" -testStateToText Don'tBuild = "do-not-build" +instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocationIndex subdirs)) where + parseJSON v + = ((noJSONWarnings . PLIndex) <$> parseJSON v) + <|> (fmap PLOther <$> parseJSON v) -instance ToJSON TestState where - toJSON = toJSON . testStateToText -instance FromJSON TestState where - parseJSON = withText "TestState" $ \t -> - case HashMap.lookup t states of - Nothing -> fail $ "Invalid state: " ++ unpack t - Just v -> return v +instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocation subdirs)) where + parseJSON v + = (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v) + <|> repo v + <|> archiveObject v where - states = HashMap.fromList - $ map (\x -> (testStateToText x, x)) [minBound..maxBound] + file t = pure $ PLFilePath $ T.unpack t + http t = + case parseRequest $ T.unpack t of + Left _ -> fail $ "Could not parse URL: " ++ T.unpack t + Right _ -> return $ PLArchive $ Archive t DefaultSubdirs Nothing -data SystemInfo = SystemInfo - { siCompilerVersion :: CompilerVersion - , siOS :: OS - , siArch :: Arch - , siCorePackages :: Map PackageName Version - , siCoreExecutables :: Set ExeName - } - deriving (Show, Eq, Ord) -instance ToJSON SystemInfo where - toJSON SystemInfo {..} = object $ - (case siCompilerVersion of - GhcVersion version -> "ghc-version" .= version - _ -> "compiler-version" .= siCompilerVersion) : - [ "os" .= display siOS - , "arch" .= display siArch - , "core-packages" .= siCorePackages - , "core-executables" .= siCoreExecutables - ] -instance FromJSON SystemInfo where - parseJSON = withObject "SystemInfo" $ \o -> do - let helper name = (o .: name) >>= either (fail . show) return . simpleParse - ghcVersion <- o .:? "ghc-version" - compilerVersion <- o .:? "compiler-version" - siCompilerVersion <- - case (ghcVersion, compilerVersion) of - (Just _, Just _) -> fail "can't have both compiler-version and ghc-version fields" - (Just ghc, _) -> return (GhcVersion ghc) - (_, Just compiler) -> return compiler - _ -> fail "expected field \"ghc-version\" or \"compiler-version\" not present" - siOS <- helper "os" - siArch <- helper "arch" - siCorePackages <- o .: "core-packages" - siCoreExecutables <- o .: "core-executables" - return SystemInfo {..} + repo = withObjectWarnings "PLRepo" $ \o -> do + (repoType, repoUrl) <- + ((RepoGit, ) <$> o ..: "git") <|> + ((RepoHg, ) <$> o ..: "hg") + repoCommit <- o ..: "commit" + repoSubdirs <- o ..:? "subdirs" ..!= DefaultSubdirs + return $ PLRepo Repo {..} -newtype Maintainer = Maintainer { unMaintainer :: Text } - deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) + archiveObject = withObjectWarnings "PLArchive" $ \o -> do + url <- o ..: "archive" + subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs + msha <- o ..:? "sha256" + msha' <- + case msha of + Nothing -> return Nothing + Just t -> + case mkStaticSHA256FromText t of + Left e -> fail $ "Invalid SHA256: " ++ T.unpack t ++ ", " ++ show e + Right x -> return $ Just x + return $ PLArchive Archive + { archiveUrl = url + , archiveSubdirs = subdirs :: Subdirs + , archiveHash = msha' + } -- | Name of an executable. newtype ExeName = ExeName { unExeName :: Text } - deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData, Data, Typeable, ToJSON, ToJSONKey, FromJSONKey) -instance FromJSON ExeName where - parseJSON = withText "ExeName" $ return . ExeName + deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData, Data, Typeable) --- | A simplified package description that tracks: --- --- * Package dependencies --- --- * Build tool dependencies +-- | A fully loaded snapshot combined , including information gleaned from the +-- global database and parsing cabal files. -- --- * Provided executables +-- Invariant: a global package may not depend upon a snapshot package, +-- a snapshot may not depend upon a local or project, and all +-- dependencies must be satisfied. +data LoadedSnapshot = LoadedSnapshot + { lsCompilerVersion :: !(CompilerVersion 'CVActual) + , lsGlobals :: !(Map PackageName (LoadedPackageInfo GhcPkgId)) + , lsPackages :: !(Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath))) + } + deriving (Generic, Show, Data, Eq, Typeable) +instance Store LoadedSnapshot +instance NFData LoadedSnapshot + +loadedSnapshotVC :: VersionConfig LoadedSnapshot +loadedSnapshotVC = storeVersionConfig "ls-v4" "a_ljrJRo8hA_-gcIDP9c6NXJ2pE=" + +-- | Information on a single package for the 'LoadedSnapshot' which +-- can be installed. -- --- It has fully resolved all conditionals -data SimpleDesc = SimpleDesc - { sdPackages :: Map PackageName DepInfo - , sdTools :: Map ExeName DepInfo - , sdProvidedExes :: Set ExeName - , sdModules :: Set Text - -- ^ modules exported by the library +-- Note that much of the information below (such as the package +-- dependencies or exposed modules) can be conditional in the cabal +-- file, which means it will vary based on flags, arch, and OS. +data LoadedPackageInfo loc = LoadedPackageInfo + { lpiVersion :: !Version + -- ^ This /must/ match the version specified within 'rpiDef'. + , lpiLocation :: !loc + -- ^ Where to get the package from. This could be a few different + -- things: + -- + -- * For a global package, it will be the @GhcPkgId@. (If we end + -- up needing to rebuild this because we've changed a + -- dependency, we will take it from the package index with no + -- @CabalFileInfo@. + -- + -- * For a dependency, it will be a @PackageLocation@. + -- + -- * For a project package, it will be a @Path Abs Dir@. + , lpiFlags :: !(Map FlagName Bool) + -- ^ Flags to build this package with. + , lpiGhcOptions :: ![Text] + -- ^ GHC options to use when building this package. + , lpiPackageDeps :: !(Map PackageName VersionIntervals) + -- ^ All packages which must be built/copied/registered before + -- this package. + , lpiProvidedExes :: !(Set ExeName) + -- ^ The names of executables provided by this package, for + -- performing build tool lookups. + , lpiNeededExes :: !(Map ExeName VersionIntervals) + -- ^ Executables needed by this package. + , lpiExposedModules :: !(Set ModuleName) + -- ^ Modules exposed by this package's library + , lpiHide :: !Bool + -- ^ Should this package be hidden in the database. Affects the + -- script interpreter's module name import parser. } - deriving (Show, Eq) -instance Monoid SimpleDesc where - mempty = SimpleDesc mempty mempty mempty mempty - mappend (SimpleDesc a b c d) (SimpleDesc w x y z) = SimpleDesc - (Map.unionWith (<>) a w) - (Map.unionWith (<>) b x) - (c <> y) - (d <> z) -instance ToJSON SimpleDesc where - toJSON SimpleDesc {..} = object - [ "packages" .= sdPackages - , "tools" .= sdTools - , "provided-exes" .= sdProvidedExes - , "modules" .= sdModules - ] -instance FromJSON SimpleDesc where - parseJSON = withObject "SimpleDesc" $ \o -> do - sdPackages <- o .: "packages" - sdTools <- o .: "tools" - sdProvidedExes <- o .: "provided-exes" - sdModules <- o .: "modules" - return SimpleDesc {..} + deriving (Generic, Show, Eq, Data, Typeable, Functor) +instance Store a => Store (LoadedPackageInfo a) +instance NFData a => NFData (LoadedPackageInfo a) data DepInfo = DepInfo - { diComponents :: Set Component - , diRange :: VersionRange + { _diComponents :: !(Set Component) + , _diRange :: !VersionIntervals } - deriving (Show, Eq) + deriving (Generic, Show, Eq, Data, Typeable) +instance Store DepInfo +instance NFData DepInfo instance Monoid DepInfo where - mempty = DepInfo mempty C.anyVersion + mempty = DepInfo mempty (fromVersionRange C.anyVersion) DepInfo a x `mappend` DepInfo b y = DepInfo (mappend a b) - (C.intersectVersionRanges x y) -instance ToJSON DepInfo where - toJSON DepInfo {..} = object - [ "components" .= diComponents - , "range" .= display diRange - ] -instance FromJSON DepInfo where - parseJSON = withObject "DepInfo" $ \o -> do - diComponents <- o .: "components" - diRange <- o .: "range" >>= either (fail . show) return . simpleParse - return DepInfo {..} + (intersectVersionIntervals x y) data Component = CompLibrary | CompExecutable | CompTestSuite | CompBenchmark - deriving (Show, Read, Eq, Ord, Enum, Bounded) - -compToText :: Component -> Text -compToText CompLibrary = "library" -compToText CompExecutable = "executable" -compToText CompTestSuite = "test-suite" -compToText CompBenchmark = "benchmark" - -instance ToJSON Component where - toJSON = toJSON . compToText -instance FromJSON Component where - parseJSON = withText "Component" $ \t -> maybe - (fail $ "Invalid component: " ++ unpack t) - return - (HashMap.lookup t comps) - where - comps = HashMap.fromList $ map (compToText &&& id) [minBound..maxBound] - --- | Convert a 'SnapName' into its short representation, e.g. @lts-2.8@, --- @nightly-2015-03-05@. -renderSnapName :: SnapName -> Text -renderSnapName (LTS x y) = T.pack $ concat ["lts-", show x, ".", show y] -renderSnapName (Nightly d) = T.pack $ "nightly-" ++ show d - --- | Parse the short representation of a 'SnapName'. -parseSnapName :: MonadThrow m => Text -> m SnapName -parseSnapName t0 = - case lts <|> nightly of - Nothing -> throwM $ ParseSnapNameException t0 - Just sn -> return sn - where - lts = do - t1 <- T.stripPrefix "lts-" t0 - Right (x, t2) <- Just $ decimal t1 - t3 <- T.stripPrefix "." t2 - Right (y, "") <- Just $ decimal t3 - return $ LTS x y - nightly = do - t1 <- T.stripPrefix "nightly-" t0 - Nightly <$> readMay (T.unpack t1) - --- | Most recent Nightly and newest LTS version per major release. -data Snapshots = Snapshots - { snapshotsNightly :: !Day - , snapshotsLts :: !(IntMap Int) - } - deriving Show -instance FromJSON Snapshots where - parseJSON = withObject "Snapshots" $ \o -> Snapshots - <$> (o .: "nightly" >>= parseNightly) - <*> fmap IntMap.unions (mapM (parseLTS . snd) - $ filter (isLTS . fst) - $ HashMap.toList o) - where - parseNightly t = - case parseSnapName t of - Left e -> fail $ show e - Right (LTS _ _) -> fail "Unexpected LTS value" - Right (Nightly d) -> return d - - isLTS = ("lts-" `T.isPrefixOf`) - - parseLTS = withText "LTS" $ \t -> - case parseSnapName t of - Left e -> fail $ show e - Right (LTS x y) -> return $ IntMap.singleton x y - Right (Nightly _) -> fail "Unexpected nightly value" - --- | A simplified version of the 'BuildPlan' + cabal file. -data MiniBuildPlan = MiniBuildPlan - { mbpCompilerVersion :: !CompilerVersion - , mbpPackages :: !(Map PackageName MiniPackageInfo) - } - deriving (Generic, Show, Eq, Data, Typeable) -instance Store MiniBuildPlan -instance NFData MiniBuildPlan - -miniBuildPlanVC :: VersionConfig MiniBuildPlan -miniBuildPlanVC = storeVersionConfig "mbp-v2" "C8q73RrYq3plf9hDCapjWpnm_yc=" - --- | Information on a single package for the 'MiniBuildPlan'. -data MiniPackageInfo = MiniPackageInfo - { mpiVersion :: !Version - , mpiFlags :: !(Map FlagName Bool) - , mpiGhcOptions :: ![Text] - , mpiPackageDeps :: !(Set PackageName) - , mpiToolDeps :: !(Set Text) - -- ^ Due to ambiguity in Cabal, it is unclear whether this refers to the - -- executable name, the package name, or something else. We have to guess - -- based on what's available, which is why we store this in an unwrapped - -- 'Text'. - , mpiExes :: !(Set ExeName) - -- ^ Executables provided by this package - , mpiHasLibrary :: !Bool - -- ^ Is there a library present? - , mpiGitSHA1 :: !(Maybe GitSHA1) - -- ^ An optional SHA1 representation in hex format of the blob containing - -- the cabal file contents. Useful for grabbing the correct cabal file - -- revision directly from a Git repo or the 01-index.tar file - } - deriving (Generic, Show, Eq, Data, Typeable) -instance Store MiniPackageInfo -instance NFData MiniPackageInfo - --- | A SHA1 hash, but in Git format. This means that the contents are --- prefixed with @blob@ and the size of the payload before hashing, as --- Git itself does. -newtype GitSHA1 = GitSHA1 ByteString - deriving (Generic, Show, Eq, NFData, Store, Data, Typeable, Ord, Hashable) - -newtype SnapshotHash = SnapshotHash { unShapshotHash :: ByteString } - deriving (Generic, Show, Eq) - -trimmedSnapshotHash :: SnapshotHash -> ByteString -trimmedSnapshotHash = BS.take 12 . unShapshotHash + deriving (Generic, Show, Eq, Ord, Data, Typeable, Enum, Bounded) +instance Store Component +instance NFData Component newtype ModuleName = ModuleName { unModuleName :: ByteString } deriving (Show, Eq, Ord, Generic, Store, NFData, Typeable, Data) -data ModuleInfo = ModuleInfo - { miCorePackages :: !(Set PackageName) - , miModules :: !(Map ModuleName (Set PackageName)) +fromCabalModuleName :: C.ModuleName -> ModuleName +fromCabalModuleName = ModuleName . encodeUtf8 . T.intercalate "." . map T.pack . C.components + +newtype ModuleInfo = ModuleInfo + { miModules :: Map ModuleName (Set PackageName) } deriving (Show, Eq, Ord, Generic, Typeable, Data) instance Store ModuleInfo instance NFData ModuleInfo +instance Monoid ModuleInfo where + mempty = ModuleInfo mempty + mappend (ModuleInfo x) (ModuleInfo y) = + ModuleInfo (Map.unionWith Set.union x y) + moduleInfoVC :: VersionConfig ModuleInfo -moduleInfoVC = storeVersionConfig "mi-v1" "zyCpzzGXA8fTeBmKEWLa_6kF2_s=" +moduleInfoVC = storeVersionConfig "mi-v2" "8ImAfrwMVmqoSoEpt85pLvFeV3s=" + +-- | Determined the desired compiler version for this 'SnapshotDef'. +sdWantedCompilerVersion :: SnapshotDef -> CompilerVersion 'CVWanted +sdWantedCompilerVersion = either id sdWantedCompilerVersion . sdParent diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -1,17 +1,18 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} module Stack.Types.Compiler where -import Control.DeepSeq import Data.Aeson import Data.Data -import Data.Monoid ((<>)) -import Data.Store (Store) import qualified Data.Text as T -import GHC.Generics (Generic) +import Stack.Prelude import Stack.Types.Version -- | Variety of compiler to use. @@ -20,6 +21,12 @@ | Ghcjs deriving (Show, Eq, Ord) +-- | Whether the compiler version given is the wanted version (what +-- the stack.yaml file, snapshot file, or --resolver argument +-- request), or the actual installed GHC. Depending on the matching +-- requirements, these values could be different. +data CVType = CVWanted | CVActual + -- | Specifies a compiler and its version number(s). -- -- Note that despite having this datatype, stack isn't in a hurry to @@ -28,26 +35,34 @@ -- NOTE: updating this will change its binary serialization. The -- version number in the 'BinarySchema' instance for 'MiniBuildPlan' -- should be updated. -data CompilerVersion +data CompilerVersion (cvType :: CVType) = GhcVersion {-# UNPACK #-} !Version | GhcjsVersion {-# UNPACK #-} !Version -- GHCJS version {-# UNPACK #-} !Version -- GHC version deriving (Generic, Show, Eq, Ord, Data, Typeable) -instance Store CompilerVersion -instance NFData CompilerVersion -instance ToJSON CompilerVersion where +instance Store (CompilerVersion a) +instance NFData (CompilerVersion a) +instance ToJSON (CompilerVersion a) where toJSON = toJSON . compilerVersionText -instance FromJSON CompilerVersion where +instance FromJSON (CompilerVersion a) where parseJSON (String t) = maybe (fail "Failed to parse compiler version") return (parseCompilerVersion t) parseJSON _ = fail "Invalid CompilerVersion, must be String" -instance FromJSONKey CompilerVersion where +instance FromJSONKey (CompilerVersion a) where fromJSONKey = FromJSONKeyTextParser $ \k -> case parseCompilerVersion k of Nothing -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k Just parsed -> return parsed -parseCompilerVersion :: T.Text -> Maybe CompilerVersion +actualToWanted :: CompilerVersion 'CVActual -> CompilerVersion 'CVWanted +actualToWanted (GhcVersion x) = GhcVersion x +actualToWanted (GhcjsVersion x y) = GhcjsVersion x y + +wantedToActual :: CompilerVersion 'CVWanted -> CompilerVersion 'CVActual +wantedToActual (GhcVersion x) = GhcVersion x +wantedToActual (GhcjsVersion x y) = GhcjsVersion x y + +parseCompilerVersion :: T.Text -> Maybe (CompilerVersion a) parseCompilerVersion t | Just t' <- T.stripPrefix "ghc-" t , Just v <- parseVersionFromString $ T.unpack t' @@ -60,27 +75,27 @@ | otherwise = Nothing -compilerVersionText :: CompilerVersion -> T.Text +compilerVersionText :: CompilerVersion a -> T.Text compilerVersionText (GhcVersion vghc) = "ghc-" <> versionText vghc compilerVersionText (GhcjsVersion vghcjs vghc) = "ghcjs-" <> versionText vghcjs <> "_ghc-" <> versionText vghc -compilerVersionString :: CompilerVersion -> String +compilerVersionString :: CompilerVersion a -> String compilerVersionString = T.unpack . compilerVersionText -whichCompiler :: CompilerVersion -> WhichCompiler +whichCompiler :: CompilerVersion a -> WhichCompiler whichCompiler GhcVersion {} = Ghc whichCompiler GhcjsVersion {} = Ghcjs -isWantedCompiler :: VersionCheck -> CompilerVersion -> CompilerVersion -> Bool +isWantedCompiler :: VersionCheck -> CompilerVersion 'CVWanted -> CompilerVersion 'CVActual -> Bool isWantedCompiler check (GhcVersion wanted) (GhcVersion actual) = checkVersion check wanted actual isWantedCompiler check (GhcjsVersion wanted wantedGhc) (GhcjsVersion actual actualGhc) = checkVersion check wanted actual && checkVersion check wantedGhc actualGhc isWantedCompiler _ _ _ = False -getGhcVersion :: CompilerVersion -> Version +getGhcVersion :: CompilerVersion a -> Version getGhcVersion (GhcVersion v) = v getGhcVersion (GhcjsVersion _ v) = v diff --git a/src/Stack/Types/CompilerBuild.hs b/src/Stack/Types/CompilerBuild.hs --- a/src/Stack/Types/CompilerBuild.hs +++ b/src/Stack/Types/CompilerBuild.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Types.CompilerBuild (CompilerBuild(..) ,compilerBuildName @@ -5,7 +6,7 @@ ,parseCompilerBuild ) where -import Control.Monad.Catch (MonadThrow) +import Stack.Prelude import Data.Aeson.Extended (FromJSON, parseJSON, withText) import Data.Text as T diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} @@ -36,6 +37,13 @@ ,getMinimalEnvOverride -- ** BuildConfig & HasBuildConfig ,BuildConfig(..) + ,LocalPackages(..) + ,LocalPackageView(..) + ,lpvRoot + ,lpvName + ,lpvVersion + ,lpvComponents + ,NamedComponent(..) ,stackYamlL ,projectRootL ,HasBuildConfig(..) @@ -46,8 +54,6 @@ ,parseGHCVariant ,HasGHCVariant(..) ,snapshotsDir - -- ** Constraint synonym for use with StackMini - ,StackMiniM -- ** EnvConfig & HasEnvConfig ,EnvConfig(..) ,HasEnvConfig(..) @@ -56,6 +62,7 @@ -- ** ApplyGhcOptions ,ApplyGhcOptions(..) -- ** ConfigException + ,HpackExecutable(..) ,ConfigException(..) -- ** WhichSolverCmd ,WhichSolverCmd(..) @@ -76,11 +83,6 @@ ,defaultLogLevel -- ** LoadConfig ,LoadConfig(..) - -- ** PackageEntry & PackageLocation - ,PackageEntry(..) - ,TreatLikeExtraDep - ,PackageLocation(..) - ,RemotePackageType(..) -- ** PackageIndex, IndexName & IndexLocation -- Re-exports @@ -104,21 +106,14 @@ ,PvpBoundsType(..) ,parsePvpBounds -- ** ColorWhen - ,ColorWhen(..) ,readColorWhen -- ** SCM ,SCM(..) - -- ** CustomSnapshot - ,CustomSnapshot(..) - -- ** GhcOptions - ,GhcOptions(..) - ,ghcOptionsFor - -- ** PackageFlags - ,PackageFlags(..) -- * Paths ,bindirSuffix ,configInstalledCache - ,configMiniBuildPlanCache + ,configLoadedSnapshotCache + ,GlobalInfoSource(..) ,getProjectWorkDir ,docDirSuffix ,flagCacheLocal @@ -126,6 +121,7 @@ ,hpcReportDir ,installationRootDeps ,installationRootLocal + ,bindirCompilerTools ,hoogleRoot ,hoogleDatabasePath ,packageDatabaseDeps @@ -166,65 +162,54 @@ ,buildOptsHaddockL ,globalOptsBuildOptsMonoidL ,packageIndicesL - ,packageCachesL ,stackRootL ,configUrlsL ,cabalVersionL ,whichCompilerL + ,envOverrideL + ,loadedSnapshotL + ,shouldForceGhcColorFlag + ,appropriateGhcColorFlag -- * Lens reexport ,view ,to ) where -import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Exception -import Control.Monad (liftM, mzero, join) -import Control.Monad.Catch (MonadThrow, MonadMask) -import Control.Monad.Logger (LogLevel(..), MonadLoggerIO) -import Control.Monad.Reader (MonadReader, MonadIO, liftIO) -import Control.Monad.Trans.Control +import Control.Monad.Writer (tell) +import Stack.Prelude import Data.Aeson.Extended - (ToJSON, toJSON, FromJSON, parseJSON, withText, object, + (ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object, (.=), (..:), (..:?), (..!=), Value(Bool, String), withObjectWarnings, WarningParser, Object, jsonSubWarnings, - jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings) -import Data.Attoparsec.Args -import Data.ByteString (ByteString) + jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings, + FromJSONKeyFunction (FromJSONKeyTextParser)) +import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping)) import qualified Data.ByteString.Char8 as S8 -import Data.Either (partitionEithers) -import Data.HashMap.Strict (HashMap) -import Data.IORef (IORef) import Data.List (stripPrefix) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty -import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Monoid.Extra -import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import Data.Typeable import Data.Yaml (ParseException) import qualified Data.Yaml as Yaml +import Distribution.PackageDescription (GenericPackageDescription) +import qualified Distribution.PackageDescription as C import Distribution.System (Platform) import qualified Distribution.Text -import Distribution.Version (anyVersion) -import GHC.Generics (Generic) +import qualified Distribution.Types.UnqualComponentName as C +import Distribution.Version (anyVersion, mkVersion') import Generics.Deriving.Monoid (memptydefault, mappenddefault) -import Lens.Micro (Lens', lens, _1, _2, to, Getting) -import Lens.Micro.Mtl (view) -import Network.HTTP.Client (parseRequest) +import Lens.Micro (Lens', lens, _1, _2, to) import Options.Applicative (ReadM) import qualified Options.Applicative as OA import qualified Options.Applicative.Types as OA import Path import qualified Paths_stack as Meta -import Stack.Types.BuildPlan (GitSHA1, MiniBuildPlan(..), SnapName, renderSnapName) +import Stack.Constants +import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Docker @@ -235,6 +220,7 @@ import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.Resolver +import Stack.Types.Runner import Stack.Types.TemplateName import Stack.Types.Urls import Stack.Types.Version @@ -326,6 +312,8 @@ -- ^ How many concurrent jobs to run, defaults to number of capabilities ,configOverrideGccPath :: !(Maybe (Path Abs File)) -- ^ Optional gcc override path + ,configOverrideHpack :: !HpackExecutable + -- ^ Use Hpack executable (overrides bundled Hpack) ,configExtraIncludeDirs :: !(Set FilePath) -- ^ --extra-include-dirs arguments ,configExtraLibDirs :: !(Set FilePath) @@ -337,9 +325,10 @@ -- ^ Parameters for templates. ,configScmInit :: !(Maybe SCM) -- ^ Initialize SCM (e.g. git) when creating new projects. - ,configGhcOptions :: !GhcOptions - -- ^ Additional GHC options to apply to either all packages (Nothing) - -- or a specific package (Just). + ,configGhcOptionsByName :: !(Map PackageName [Text]) + -- ^ Additional GHC options to apply to specific packages. + ,configGhcOptionsByCat :: !(Map ApplyGhcOptions [Text]) + -- ^ Additional GHC options to apply to categories of packages ,configSetupInfoLocations :: ![SetupInfoLocation] -- ^ Additional SetupInfo (inline or remote) to use to find tools. ,configPvpBounds :: !PvpBounds @@ -361,8 +350,7 @@ ,configAllowDifferentUser :: !Bool -- ^ Allow users other than the stack root owner to use the stack -- installation. - ,configPackageCaches :: !(IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache), - HashMap GitSHA1 (PackageIndex, OffsetSize)))) + ,configPackageCache :: !(IORef (Maybe (PackageCache PackageIndex))) -- ^ In memory cache of hackage index. ,configDumpLogs :: !DumpLogs -- ^ Dump logs of local non-dependencies when doing a build. @@ -374,8 +362,18 @@ -- command disallows this. ,configSaveHackageCreds :: !Bool -- ^ Should we save Hackage credentials to a file? + ,configRunner :: !Runner + ,configIgnoreRevisionMismatch :: !Bool + -- ^ Ignore a revision mismatch when loading up cabal files, + -- and fall back to the latest revision. See: + -- } +data HpackExecutable + = HpackBundled + | HpackCommand String + deriving (Show, Read, Eq, Ord) + -- | Which packages do ghc-options on the command line apply to? data ApplyGhcOptions = AGOTargets -- ^ all local targets | AGOLocals -- ^ all local packages, even non-targets @@ -420,6 +418,8 @@ -- ^ set the STACK_EXE variable to the current executable name , esLocaleUtf8 :: !Bool -- ^ set the locale to C.UTF-8 + , esKeepGhcRts :: !Bool + -- ^ if True, keep GHCRTS variable in environment } deriving (Show, Eq, Ord) @@ -441,6 +441,7 @@ { eoEnvSettings :: !EnvSettings , eoPackages :: ![String] , eoRtsOptions :: ![String] + , eoCwd :: !(Maybe FilePath) } deriving (Show) @@ -458,16 +459,19 @@ , globalTimeInLog :: !Bool -- ^ Whether to include timings in logs. , globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' , globalResolver :: !(Maybe AbstractResolver) -- ^ Resolver override - , globalCompiler :: !(Maybe CompilerVersion) -- ^ Compiler override + , globalCompiler :: !(Maybe (CompilerVersion 'CVWanted)) -- ^ Compiler override , globalTerminal :: !Bool -- ^ We're in a terminal? , globalColorWhen :: !ColorWhen -- ^ When to use ansi terminal colors + , globalTermWidth :: !(Maybe Int) -- ^ Terminal width override , globalStackYaml :: !(StackYamlLoc FilePath) -- ^ Override project stack.yaml } deriving (Show) data StackYamlLoc filepath = SYLDefault | SYLOverride !filepath - | SYLNoConfig + | SYLNoConfig !(Path Abs Dir) + -- ^ FilePath is the directory containing the script file, used + -- for resolving custom snapshot files. deriving (Show,Functor,Foldable,Traversable) -- | Parsed global command-line options monoid. @@ -479,9 +483,10 @@ , globalMonoidTimeInLog :: !(First Bool) -- ^ Whether to include timings in logs. , globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' , globalMonoidResolver :: !(First AbstractResolver) -- ^ Resolver override - , globalMonoidCompiler :: !(First CompilerVersion) -- ^ Compiler override + , globalMonoidCompiler :: !(First (CompilerVersion 'CVWanted)) -- ^ Compiler override , globalMonoidTerminal :: !(First Bool) -- ^ We're in a terminal? , globalMonoidColorWhen :: !(First ColorWhen) -- ^ When to use ansi colors + , globalMonoidTermWidth :: !(First Int) -- ^ Terminal width override , globalMonoidStackYaml :: !(First FilePath) -- ^ Override project stack.yaml } deriving (Show, Generic) @@ -493,9 +498,6 @@ defaultLogLevel :: LogLevel defaultLogLevel = LevelInfo -data ColorWhen = ColorNever | ColorAlways | ColorAuto - deriving (Show, Generic) - readColorWhen :: ReadM ColorWhen readColorWhen = do s <- OA.readerAsk @@ -512,16 +514,13 @@ -- These are the components which know nothing about local configuration. data BuildConfig = BuildConfig { bcConfig :: !Config - , bcResolver :: !LoadedResolver - -- ^ How we resolve which dependencies to install given a set of - -- packages. - , bcWantedMiniBuildPlan :: !MiniBuildPlan + , bcSnapshotDef :: !SnapshotDef -- ^ Build plan wanted for this build , bcGHCVariant :: !GHCVariant -- ^ The variant of GHC used to select a GHC bindist. - , bcPackageEntries :: ![PackageEntry] + , bcPackages :: ![PackageLocation Subdirs] -- ^ Local packages - , bcExtraDeps :: !(Map PackageName Version) + , bcDependencies :: ![PackageLocationIndex Subdirs] -- ^ Extra dependencies specified in configuration. -- -- These dependencies will not be installed to a shared location, and @@ -536,7 +535,7 @@ -- -- FIXME MSS 2016-12-08: is the above comment still true? projectRootL -- is defined in terms of bcStackYaml - , bcFlags :: !PackageFlags + , bcFlags :: !(Map PackageName (Map FlagName Bool)) -- ^ Per-package flag overrides , bcImplicitGlobal :: !Bool -- ^ Are we loading from the implicit global stack.yaml? This is useful @@ -560,20 +559,81 @@ -- Note that this is not necessarily the same version as the one that stack -- depends on as a library and which is displayed when running -- @stack list-dependencies | grep Cabal@ in the stack project. - ,envConfigCompilerVersion :: !CompilerVersion + ,envConfigCompilerVersion :: !(CompilerVersion 'CVActual) -- ^ The actual version of the compiler to be used, as opposed to -- 'wantedCompilerL', which provides the version specified by the -- build plan. ,envConfigCompilerBuild :: !CompilerBuild - ,envConfigPackagesRef :: !(IORef (Maybe (Map (Path Abs Dir) TreatLikeExtraDep))) + ,envConfigPackagesRef :: !(IORef (Maybe LocalPackages)) -- ^ Cache for 'getLocalPackages'. + ,envConfigLoadedSnapshot :: !LoadedSnapshot + -- ^ The fully resolved snapshot information. } +data LocalPackages = LocalPackages + { lpProject :: !(Map PackageName LocalPackageView) + , lpDependencies :: !(Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath)) + } + +-- | A view of a local package needed for resolving components +data LocalPackageView = LocalPackageView + { lpvCabalFP :: !(Path Abs File) + , lpvGPD :: !GenericPackageDescription + , lpvLoc :: !(PackageLocation FilePath) + } + +-- | Root directory for the given 'LocalPackageView' +lpvRoot :: LocalPackageView -> Path Abs Dir +lpvRoot = parent . lpvCabalFP + +-- | Package name for the given 'LocalPackageView +lpvName :: LocalPackageView -> PackageName +lpvName lpv = + let PackageIdentifier name _version = + fromCabalPackageIdentifier + $ C.package + $ C.packageDescription + $ lpvGPD lpv + in name + +-- | All components available in the given 'LocalPackageView' +lpvComponents :: LocalPackageView -> Set NamedComponent +lpvComponents lpv = Set.fromList $ concat + [ maybe [] (const [CLib]) (C.condLibrary gpkg) + , go CExe (map fst . C.condExecutables) + , go CTest (map fst . C.condTestSuites) + , go CBench (map fst . C.condBenchmarks) + ] + where + gpkg = lpvGPD lpv + go :: (T.Text -> NamedComponent) + -> (C.GenericPackageDescription -> [C.UnqualComponentName]) + -> [NamedComponent] + go wrapper f = map (wrapper . T.pack . C.unUnqualComponentName) $ f gpkg + +-- | Version for the given 'LocalPackageView +lpvVersion :: LocalPackageView -> Version +lpvVersion lpv = + let PackageIdentifier _name version = + fromCabalPackageIdentifier + $ C.package + $ C.packageDescription + $ lpvGPD lpv + in version + +-- | A single, fully resolved component of a package +data NamedComponent + = CLib + | CExe !Text + | CTest !Text + | CBench !Text + deriving (Show, Eq, Ord) + -- | Value returned by 'Stack.Config.loadConfig'. -data LoadConfig m = LoadConfig +data LoadConfig = LoadConfig { lcConfig :: !Config -- ^ Top-level Stack configuration. - , lcLoadBuildConfig :: !(Maybe CompilerVersion -> m BuildConfig) + , lcLoadBuildConfig :: !(Maybe (CompilerVersion 'CVWanted) -> IO BuildConfig) -- ^ Action to load the remaining 'BuildConfig'. , lcProjectRoot :: !(Maybe (Path Abs Dir)) -- ^ The project root directory, if in a project. @@ -581,15 +641,11 @@ data PackageEntry = PackageEntry { peExtraDepMaybe :: !(Maybe TreatLikeExtraDep) - , peLocation :: !PackageLocation - , peSubdirs :: ![FilePath] + , peLocation :: !(PackageLocation Subdirs) + , peSubdirs :: !Subdirs } deriving Show --- | Perform defaulting of peExtraDepMaybe -peExtraDepDef :: PackageEntry -> TreatLikeExtraDep -peExtraDepDef = fromMaybe False . peExtraDepMaybe - -- | Should a package be treated just like an extra-dep? -- -- 'True' means, it will only be built as a dependency @@ -600,14 +656,6 @@ -- https://github.com/commercialhaskell/stack/issues/386 type TreatLikeExtraDep = Bool -instance ToJSON PackageEntry where - toJSON pe | not (peExtraDepDef pe) && null (peSubdirs pe) = - toJSON $ peLocation pe - toJSON pe = object $ - maybe id (\e -> (("extra-dep" .= e):)) (peExtraDepMaybe pe) - [ "location" .= peLocation pe - , "subdirs" .= peSubdirs pe - ] instance FromJSON (WithJSONWarnings PackageEntry) where parseJSON (String t) = do WithJSONWarnings loc _ <- parseJSON $ String t @@ -615,51 +663,12 @@ PackageEntry { peExtraDepMaybe = Nothing , peLocation = loc - , peSubdirs = [] + , peSubdirs = DefaultSubdirs } parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry <$> o ..:? "extra-dep" <*> jsonSubWarnings (o ..: "location") - <*> o ..:? "subdirs" ..!= []) v - -data PackageLocation - = PLFilePath FilePath - -- ^ Note that we use @FilePath@ and not @Path@s. The goal is: first parse - -- the value raw, and then use @canonicalizePath@ and @parseAbsDir@. - | PLRemote Text RemotePackageType - -- ^ URL and further details - deriving Show - -data RemotePackageType - = RPTHttp - | RPTGit Text -- ^ Commit - | RPTHg Text -- ^ Commit - deriving Show - -instance ToJSON PackageLocation where - toJSON (PLFilePath fp) = toJSON fp - toJSON (PLRemote t RPTHttp) = toJSON t - toJSON (PLRemote x (RPTGit y)) = object [("git", toJSON x), ("commit", toJSON y)] - toJSON (PLRemote x (RPTHg y)) = object [( "hg", toJSON x), ("commit", toJSON y)] - -instance FromJSON (WithJSONWarnings PackageLocation) where - parseJSON v - = (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v) - <|> git v - <|> hg v - where - file t = pure $ PLFilePath $ T.unpack t - http t = - case parseRequest $ T.unpack t of - Left _ -> mzero - Right _ -> return $ PLRemote t RPTHttp - - git = withObjectWarnings "PackageGitLocation" $ \o -> PLRemote - <$> o ..: "git" - <*> (RPTGit <$> o ..: "commit") - hg = withObjectWarnings "PackageHgLocation" $ \o -> PLRemote - <$> o ..: "hg" - <*> (RPTHg <$> o ..: "commit") + <*> o ..:? "subdirs" ..!= DefaultSubdirs) v -- | A project is a collection of packages. We can have multiple stack.yaml -- files, but only one of them may contain project information. @@ -667,37 +676,40 @@ { projectUserMsg :: !(Maybe String) -- ^ A warning message to display to the user when the auto generated -- config may have issues. - , projectPackages :: ![PackageEntry] - -- ^ Components of the package list - , projectExtraDeps :: !(Map PackageName Version) - -- ^ Components of the package list referring to package/version combos, - -- see: https://github.com/fpco/stack/issues/41 - , projectFlags :: !PackageFlags - -- ^ Per-package flag overrides + , projectPackages :: ![PackageLocation Subdirs] + -- ^ Packages which are actually part of the project (as opposed + -- to dependencies). + -- + -- /NOTE/ Stack has always allowed these packages to be any kind + -- of package location, but in reality only @PLFilePath@ really + -- makes sense. We could consider replacing @[PackageLocation]@ + -- with @[FilePath]@ to properly enforce this idea, though it will + -- slightly break backwards compatibility if someone really did + -- want to treat such things as non-deps. + , projectDependencies :: ![PackageLocationIndex Subdirs] + -- ^ Dependencies defined within the stack.yaml file, to be + -- applied on top of the snapshot. + , projectFlags :: !(Map PackageName (Map FlagName Bool)) + -- ^ Flags to be applied on top of the snapshot flags. , projectResolver :: !Resolver - -- ^ How we resolve which dependencies to use - , projectCompiler :: !(Maybe CompilerVersion) + -- ^ How we resolve which @SnapshotDef@ to use + , projectCompiler :: !(Maybe (CompilerVersion 'CVWanted)) -- ^ When specified, overrides which compiler to use , projectExtraPackageDBs :: ![FilePath] } deriving Show instance ToJSON Project where - toJSON p = object $ - maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p) $ - maybe id (\msg -> (("user-message" .= msg) :)) (projectUserMsg p) - [ "packages" .= projectPackages p - , "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p) - , "flags" .= projectFlags p - , "resolver" .= projectResolver p - , "extra-package-dbs" .= projectExtraPackageDBs p - ] - --- | Constraint synonym for constraints satisfied by a 'MiniConfig' --- environment. -type StackMiniM r m = - ( MonadReader r m, MonadIO m, MonadBaseControl IO m, MonadLoggerIO m, MonadMask m - ) + -- Expanding the constructor fully to ensure we don't miss any fields. + toJSON (Project userMsg packages extraDeps flags resolver compiler extraPackageDBs) = object $ concat + [ maybe [] (\cv -> ["compiler" .= cv]) compiler + , maybe [] (\msg -> ["user-message" .= msg]) userMsg + , if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs] + , if null extraDeps then [] else ["extra-deps" .= extraDeps] + , if Map.null flags then [] else ["flags" .= flags] + , ["packages" .= packages] + , ["resolver" .= resolver] + ] -- An uninterpreted representation of configuration options. -- Configurations may be "cascaded" using mappend (left-biased). @@ -749,6 +761,8 @@ -- ^ See: 'configExtraLibDirs' , configMonoidOverrideGccPath :: !(First (Path Abs File)) -- ^ Allow users to override the path to gcc + ,configMonoidOverrideHpack :: !(First FilePath) + -- ^ Use Hpack executable (overrides bundled Hpack) ,configMonoidConcurrentTests :: !(First Bool) -- ^ See: 'configConcurrentTests' ,configMonoidLocalBinPath :: !(First FilePath) @@ -759,8 +773,10 @@ -- ^ Template parameters. ,configMonoidScmInit :: !(First SCM) -- ^ Initialize SCM (e.g. git init) when making new projects? - ,configMonoidGhcOptions :: !GhcOptions - -- ^ See 'configGhcOptions' + ,configMonoidGhcOptionsByName :: !(Map PackageName [Text]) + -- ^ See 'configGhcOptionsByName' + ,configMonoidGhcOptionsByCat :: !(Map ApplyGhcOptions [Text]) + -- ^ See 'configGhcOptionsAll' ,configMonoidExtraPath :: ![Path Abs Dir] -- ^ Additional paths to search for executables in ,configMonoidSetupInfoLocations :: ![SetupInfoLocation] @@ -789,6 +805,8 @@ -- ^ See 'configDumpLogs' , configMonoidSaveHackageCreds :: !(First Bool) -- ^ See 'configSaveHackageCreds' + , configMonoidIgnoreRevisionMismatch :: !(First Bool) + -- ^ See 'configIgnoreRevisionMismatch' } deriving (Show, Generic) @@ -831,6 +849,7 @@ configMonoidExtraLibDirs <- fmap (Set.map (toFilePath rootDir FilePath.)) $ obj ..:? configMonoidExtraLibDirsName ..!= Set.empty configMonoidOverrideGccPath <- First <$> obj ..:? configMonoidOverrideGccPathName + configMonoidOverrideHpack <- First <$> obj ..:? configMonoidOverrideHpackName configMonoidConcurrentTests <- First <$> obj ..:? configMonoidConcurrentTestsName configMonoidLocalBinPath <- First <$> obj ..:? configMonoidLocalBinPathName configMonoidImageOpts <- jsonSubWarnings (obj ..:? configMonoidImageOptsName ..!= mempty) @@ -844,7 +863,26 @@ return (First scmInit,fromMaybe M.empty params) configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName - configMonoidGhcOptions <- obj ..:? configMonoidGhcOptionsName ..!= mempty + options <- Map.map unGhcOptions <$> obj ..:? configMonoidGhcOptionsName ..!= mempty + + optionsEverything <- + case (Map.lookup GOKOldEverything options, Map.lookup GOKEverything options) of + (Just _, Just _) -> fail "Cannot specify both `*` and `$everything` GHC options" + (Nothing, Just x) -> return x + (Just x, Nothing) -> do + tell "The `*` ghc-options key is not recommended. Consider using $locals, or if really needed, $everything" + return x + (Nothing, Nothing) -> return [] + + let configMonoidGhcOptionsByCat = Map.fromList + [ (AGOEverything, optionsEverything) + , (AGOLocals, Map.findWithDefault [] GOKLocals options) + , (AGOTargets, Map.findWithDefault [] GOKTargets options) + ] + + configMonoidGhcOptionsByName = Map.fromList + [(name, opts) | (GOKPackage name, opts) <- Map.toList options] + configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= [] configMonoidSetupInfoLocations <- maybeToList <$> jsonSubWarningsT (obj ..:? configMonoidSetupInfoLocationsName) @@ -861,6 +899,7 @@ configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName configMonoidSaveHackageCreds <- First <$> obj ..:? configMonoidSaveHackageCredsName + configMonoidIgnoreRevisionMismatch <- First <$> obj ..:? configMonoidIgnoreRevisionMismatchName return ConfigMonoid {..} where @@ -937,6 +976,9 @@ configMonoidOverrideGccPathName :: Text configMonoidOverrideGccPathName = "with-gcc" +configMonoidOverrideHpackName :: Text +configMonoidOverrideHpackName = "with-hpack" + configMonoidConcurrentTestsName :: Text configMonoidConcurrentTestsName = "concurrent-tests" @@ -997,17 +1039,19 @@ configMonoidSaveHackageCredsName :: Text configMonoidSaveHackageCredsName = "save-hackage-creds" +configMonoidIgnoreRevisionMismatchName :: Text +configMonoidIgnoreRevisionMismatchName = "ignore-revision-mismatch" + data ConfigException = ParseConfigFileException (Path Abs File) ParseException | ParseCustomSnapshotException Text ParseException - | ParseResolverException Text | NoProjectConfigFound (Path Abs Dir) (Maybe Text) | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File] | UnableToExtractArchive Text (Path Abs File) | BadStackVersionException VersionRange | NoMatchingSnapshot WhichSolverCmd (NonEmpty SnapName) - | forall l. ResolverMismatch WhichSolverCmd (ResolverThat's l) String - | ResolverPartial WhichSolverCmd Resolver String + | ResolverMismatch WhichSolverCmd !Text String -- Text == resolver name, sdName + | ResolverPartial WhichSolverCmd !Text String -- Text == resolver name, sdName | NoSuchDirectory FilePath | ParseGHCVariantException String | BadStackRoot (Path Abs Dir) @@ -1018,6 +1062,7 @@ | NixRequiresSystemGhc | NoResolverWhenUsingNoLocalConfig | InvalidResolverForNoLocalConfig String + | DuplicateLocalPackageNames ![(PackageName, [PackageLocationIndex FilePath])] deriving Typeable instance Show ConfigException where show (ParseConfigFileException configFile exception) = concat @@ -1035,12 +1080,6 @@ -- FIXME: Link to docs about custom snapshots -- , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/" ] - show (ParseResolverException t) = concat - [ "Invalid resolver value: " - , T.unpack t - , ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, ghc-7.10.2, and ghcjs-0.1.0_ghc-7.10.2. " - , "See https://www.stackage.org/snapshots for a complete list." - ] show (NoProjectConfigFound dir mcmd) = concat [ "Unable to find a stack.yaml file in the current directory (" , toFilePath dir @@ -1062,7 +1101,7 @@ ] show (BadStackVersionException requiredRange) = concat [ "The version of stack you are using (" - , show (fromCabalVersion Meta.version) + , show (fromCabalVersion (mkVersion' Meta.version)) , ") is outside the required\n" ,"version range specified in stack.yaml (" , T.unpack (versionRangeText requiredRange) @@ -1076,7 +1115,7 @@ ] show (ResolverMismatch whichCmd resolver errDesc) = concat [ "Resolver '" - , T.unpack (resolverName resolver) + , T.unpack resolver , "' does not have a matching compiler to build some or all of your " , "package(s).\n" , errDesc @@ -1084,7 +1123,7 @@ ] show (ResolverPartial whichCmd resolver errDesc) = concat [ "Resolver '" - , T.unpack (resolverName resolver) + , T.unpack resolver , "' does not have all the packages to match your requirements.\n" , unlines $ fmap (" " <>) (lines errDesc) , showOptions whichCmd @@ -1138,6 +1177,15 @@ ] show NoResolverWhenUsingNoLocalConfig = "When using the script command, you must provide a resolver argument" show (InvalidResolverForNoLocalConfig ar) = "The script command requires a specific resolver, you provided " ++ ar + show (DuplicateLocalPackageNames pairs) = concat + $ "The same package name is used in multiple local packages\n" + : map go pairs + where + go (name, dirs) = unlines + $ "" + : (packageNameString name ++ " used in:") + : map goLoc dirs + goLoc loc = "- " ++ show loc instance Exception ConfigException showOptions :: WhichSolverCmd -> SuggestSolver -> String @@ -1248,6 +1296,20 @@ psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel return $ workDir $(mkRelDir "install") psc +-- | Installation root for compiler tools +bindirCompilerTools :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) +bindirCompilerTools = do + config <- view configL + platform <- platformGhcRelDir + compilerVersion <- envConfigCompilerVersion <$> view envConfigL + compiler <- parseRelDir $ compilerVersionString compilerVersion + return $ + configStackRoot config + $(mkRelDir "compiler-tools") + platform + compiler + bindirSuffix + -- | Hoogle directory. hoogleRoot :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) hoogleRoot = do @@ -1267,9 +1329,9 @@ :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Rel Dir) platformSnapAndCompilerRel = do - resolver' <- view loadedResolverL + sd <- view snapshotDefL platform <- platformGhcRelDir - name <- parseRelDir $ T.unpack $ resolverDirName resolver' + name <- parseRelDir $ sdRawPathName sd ghc <- compilerVersionDir useShaPathOnWindows (platform name ghc) @@ -1344,17 +1406,31 @@ root <- installationRootLocal return $ root $(mkRelDir "flag-cache") --- | Where to store mini build plan caches -configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasConfig env, HasGHCVariant env) - => SnapName - -> m (Path Abs File) -configMiniBuildPlanCache name = do +-- | Where to store 'LoadedSnapshot' caches +configLoadedSnapshotCache + :: (MonadThrow m, MonadReader env m, HasConfig env, HasGHCVariant env) + => SnapshotDef + -> GlobalInfoSource + -> m (Path Abs File) +configLoadedSnapshotCache sd gis = do root <- view stackRootL platform <- platformGhcVerOnlyRelDir - file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache" + file <- parseRelFile $ sdRawPathName sd ++ ".cache" + gis' <- parseRelDir $ + case gis of + GISSnapshotHints -> "__snapshot_hints__" + GISCompiler cv -> compilerVersionString cv -- Yes, cached plans differ based on platform - return (root $(mkRelDir "build-plan-cache") platform file) + return (root $(mkRelDir "loaded-snapshot-cache") platform gis' file) +-- | Where do we get information on global packages for loading up a +-- 'LoadedSnapshot'? +data GlobalInfoSource + = GISSnapshotHints + -- ^ Accept the hints in the snapshot definition + | GISCompiler (CompilerVersion 'CVActual) + -- ^ Look up the actual information in the installed compiler + -- | Suffix applied to an installation root to get the bin dir bindirSuffix :: Path Rel Dir bindirSuffix = $(mkRelDir "bin") @@ -1378,9 +1454,10 @@ extraBinDirs = do deps <- installationRootDeps local <- installationRootLocal + tools <- bindirCompilerTools return $ \locals -> if locals - then [local bindirSuffix, deps bindirSuffix] - else [deps bindirSuffix] + then [local bindirSuffix, deps bindirSuffix, tools] + else [deps bindirSuffix, tools] -- | Get the minimal environment override, useful for just calling external -- processes like git or ghc @@ -1396,6 +1473,7 @@ , esIncludeGhcPackagePath = False , esStackExe = False , esLocaleUtf8 = False + , esKeepGhcRts = False } -- | Get the path for the given compiler ignoring any local binaries. @@ -1418,52 +1496,81 @@ parseProjectAndConfigMonoid rootDir = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do dirs <- jsonSubWarningsTT (o ..:? "packages") ..!= [packageEntryCurrDir] - extraDeps' <- o ..:? "extra-deps" ..!= [] - extraDeps <- - case partitionEithers $ goDeps extraDeps' of - ([], x) -> return $ Map.fromList x - (errs, _) -> fail $ unlines errs - + extraDeps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] flags <- o ..:? "flags" ..!= mempty - resolver <- jsonSubWarnings (o ..: "resolver") + + -- Convert the packages/extra-deps/flags approach we use in + -- the stack.yaml into the internal representation. + let (packages, deps) = convert dirs extraDeps + + resolver <- (o ..: "resolver") + >>= either (fail . show) return + . parseCustomLocation (Just rootDir) compiler <- o ..:? "compiler" msg <- o ..:? "user-message" config <- parseConfigMonoidObject rootDir o extraPackageDBs <- o ..:? "extra-package-dbs" ..!= [] let project = Project { projectUserMsg = msg - , projectPackages = dirs - , projectExtraDeps = extraDeps - , projectFlags = flags , projectResolver = resolver , projectCompiler = compiler , projectExtraPackageDBs = extraPackageDBs + , projectPackages = packages + , projectDependencies = deps + , projectFlags = flags } return $ ProjectAndConfigMonoid project config where - goDeps = - map toSingle . Map.toList . Map.unionsWith Set.union . map toMap + convert :: [PackageEntry] + -> [PackageLocationIndex Subdirs] -- extra-deps + -> ( [PackageLocation Subdirs] -- project + , [PackageLocationIndex Subdirs] -- dependencies + ) + convert entries extraDeps = + partitionEithers $ concatMap goEntry entries ++ map Right extraDeps where - toMap i = Map.singleton - (packageIdentifierName i) - (Set.singleton (packageIdentifierVersion i)) + goEntry :: PackageEntry -> [Either (PackageLocation Subdirs) (PackageLocationIndex Subdirs)] + goEntry (PackageEntry Nothing pl@(PLFilePath _) subdirs) = goEntry' False pl subdirs + goEntry (PackageEntry Nothing pl _) = fail $ concat + [ "Refusing to implicitly treat package location as an extra-dep:\n" + , show pl + , "\nRecommendation: either move to 'extra-deps' or set 'extra-dep: true'." + ] + goEntry (PackageEntry (Just extraDep) pl subdirs) = goEntry' extraDep pl subdirs - toSingle (k, s) = - case Set.toList s of - [x] -> Right (k, x) - xs -> Left $ concat - [ "Multiple versions for package " - , packageNameString k - , ": " - , unwords $ map versionString xs - ] + goEntry' :: Bool -- ^ extra dep? + -> PackageLocation Subdirs + -> Subdirs + -> [Either (PackageLocation Subdirs) (PackageLocationIndex Subdirs)] + goEntry' extraDep pl subdirs = + map (if extraDep then Right . PLOther else Left) (addSubdirs pl subdirs) + combineSubdirs :: [FilePath] -> Subdirs -> Subdirs + combineSubdirs paths DefaultSubdirs = ExplicitSubdirs paths + -- this could be considered an error condition, but we'll + -- just try and make it work + combineSubdirs paths (ExplicitSubdirs paths') = ExplicitSubdirs (paths ++ paths') + + -- We do the toList/fromList bit as an efficient nub, and + -- to avoid having duplicate subdir names (especially for + -- the "." case, where parsing gets wonky). + addSubdirs :: PackageLocation Subdirs + -> Subdirs + -> [PackageLocation Subdirs] + addSubdirs pl DefaultSubdirs = [pl] + addSubdirs (PLRepo repo) (ExplicitSubdirs subdirs) = + [PLRepo repo { repoSubdirs = combineSubdirs subdirs $ repoSubdirs repo }] + addSubdirs (PLArchive arch) (ExplicitSubdirs subdirs) = + [PLArchive arch { archiveSubdirs = combineSubdirs subdirs $ archiveSubdirs arch }] + addSubdirs (PLFilePath fp) (ExplicitSubdirs subdirs) = + map (\subdir -> PLFilePath $ fp FilePath. subdir) subdirs + -- | A PackageEntry for the current directory, used as a default packageEntryCurrDir :: PackageEntry packageEntryCurrDir = PackageEntry { peExtraDepMaybe = Nothing , peLocation = PLFilePath "." - , peSubdirs = [] + , peSubdirs = DefaultSubdirs } -- | A software control system. @@ -1532,6 +1639,7 @@ -- ^ URL or absolute file path , downloadInfoContentLength :: Maybe Int , downloadInfoSha1 :: Maybe ByteString + , downloadInfoSha256 :: Maybe ByteString } deriving (Show) instance FromJSON (WithJSONWarnings DownloadInfo) where @@ -1543,11 +1651,13 @@ url <- o ..: "url" contentLength <- o ..:? "content-length" sha1TextMay <- o ..:? "sha1" + sha256TextMay <- o ..:? "sha256" return DownloadInfo { downloadInfoUrl = url , downloadInfoContentLength = contentLength , downloadInfoSha1 = fmap encodeUtf8 sha1TextMay + , downloadInfoSha256 = fmap encodeUtf8 sha256TextMay } data VersionedDownloadInfo = VersionedDownloadInfo @@ -1588,7 +1698,7 @@ , siSevenzDll :: Maybe DownloadInfo , siMsys2 :: Map Text VersionedDownloadInfo , siGHCs :: Map Text (Map Version GHCDownloadInfo) - , siGHCJSs :: Map Text (Map CompilerVersion DownloadInfo) + , siGHCJSs :: Map Text (Map (CompilerVersion 'CVActual) DownloadInfo) , siStack :: Map Text (Map Version DownloadInfo) } deriving Show @@ -1710,81 +1820,34 @@ , duUmask :: FileMode -- ^ File creation mask } } deriving (Read,Show) --- TODO: See section of --- https://github.com/commercialhaskell/stack/issues/1265 about --- rationalizing the config. It would also be nice to share more code. --- For now it's more convenient just to extend this type. However, it's --- unpleasant that it has overlap with both 'Project' and 'Config'. -data CustomSnapshot = CustomSnapshot - { csCompilerVersion :: !(Maybe CompilerVersion) - , csPackages :: !(Set PackageIdentifier) - , csDropPackages :: !(Set PackageName) - , csFlags :: !PackageFlags - , csGhcOptions :: !GhcOptions - } +data GhcOptionKey + = GOKOldEverything + | GOKEverything + | GOKLocals + | GOKTargets + | GOKPackage !PackageName + deriving (Eq, Ord) -instance FromJSON (WithJSONWarnings (CustomSnapshot, Maybe Resolver)) where - parseJSON = withObjectWarnings "CustomSnapshot" $ \o -> (,) - <$> (CustomSnapshot - <$> o ..:? "compiler" - <*> o ..:? "packages" ..!= mempty - <*> o ..:? "drop-packages" ..!= mempty - <*> o ..:? "flags" ..!= mempty - <*> o ..:? configMonoidGhcOptionsName ..!= mempty) - <*> jsonSubWarningsT (o ..:? "resolver") +instance FromJSONKey GhcOptionKey where + fromJSONKey = FromJSONKeyTextParser $ \t -> + case t of + "*" -> return GOKOldEverything + "$everything" -> return GOKEverything + "$locals" -> return GOKLocals + "$targets" -> return GOKTargets + _ -> + case parsePackageName t of + Left e -> fail $ show e + Right x -> return $ GOKPackage x + fromJSONKeyList = FromJSONKeyTextParser $ \_ -> fail "GhcOptionKey.fromJSONKeyList" -newtype GhcOptions = GhcOptions - { unGhcOptions :: Map (Maybe PackageName) [Text] } - deriving Show +newtype GhcOptions = GhcOptions { unGhcOptions :: [Text] } instance FromJSON GhcOptions where - parseJSON val = do - ghcOptions <- parseJSON val - fmap (GhcOptions . Map.fromList) $ mapM handleGhcOptions $ Map.toList ghcOptions - where - handleGhcOptions :: Monad m => (Text, Text) -> m (Maybe PackageName, [Text]) - handleGhcOptions (name', vals') = do - name <- - if name' == "*" - then return Nothing - else case parsePackageNameFromString $ T.unpack name' of - Left e -> fail $ show e - Right x -> return $ Just x - - case parseArgs Escaping vals' of - Left e -> fail e - Right vals -> return (name, map T.pack vals) - -instance Monoid GhcOptions where - mempty = GhcOptions mempty - -- FIXME: Should GhcOptions really monoid like this? Keeping it this - -- way preserves the behavior of the ConfigMonoid. However, this - -- means there isn't the ability to fully override snapshot - -- ghc-options in the same way there is for flags. Do we want to - -- change the semantics here? (particularly for extensible - -- snapshots) - mappend (GhcOptions l) (GhcOptions r) = - GhcOptions (Map.unionWith (++) l r) - -ghcOptionsFor :: PackageName -> GhcOptions -> [Text] -ghcOptionsFor name (GhcOptions mp) = - M.findWithDefault [] Nothing mp ++ - M.findWithDefault [] (Just name) mp - -newtype PackageFlags = PackageFlags - { unPackageFlags :: Map PackageName (Map FlagName Bool) } - deriving Show - -instance FromJSON PackageFlags where - parseJSON val = PackageFlags <$> parseJSON val - -instance ToJSON PackageFlags where - toJSON = toJSON . unPackageFlags - -instance Monoid PackageFlags where - mempty = PackageFlags mempty - mappend (PackageFlags l) (PackageFlags r) = - PackageFlags (Map.unionWith Map.union l r) + parseJSON = withText "GhcOptions" $ \t -> + case parseArgs Escaping t of + Left e -> fail e + Right opts -> return $ GhcOptions $ map T.pack opts ----------------------------------- -- Lens classes @@ -1809,7 +1872,7 @@ {-# INLINE ghcVariantL #-} -- | Class for environment values that can provide a 'Config'. -class HasPlatform env => HasConfig env where +class (HasPlatform env, HasRunner env) => HasConfig env where configL :: Lens' env Config default configL :: HasBuildConfig env => Lens' env Config configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y }) @@ -1835,6 +1898,7 @@ instance HasPlatform Config where platformL = lens configPlatform (\x y -> x { configPlatform = y }) platformVariantL = lens configPlatformVariant (\x y -> x { configPlatformVariant = y }) +instance HasPlatform LoadConfig instance HasPlatform BuildConfig instance HasPlatform EnvConfig @@ -1848,6 +1912,8 @@ instance HasConfig Config where configL = id {-# INLINE configL #-} +instance HasConfig LoadConfig where + configL = lens lcConfig (\x y -> x { lcConfig = y }) instance HasConfig BuildConfig where configL = lens bcConfig (\x y -> x { bcConfig = y }) instance HasConfig EnvConfig @@ -1861,6 +1927,24 @@ envConfigL = id {-# INLINE envConfigL #-} +instance HasRunner Config where + runnerL = lens configRunner (\x y -> x { configRunner = y }) +instance HasRunner LoadConfig where + runnerL = configL.runnerL +instance HasRunner BuildConfig where + runnerL = configL.runnerL +instance HasRunner EnvConfig where + runnerL = configL.runnerL + +instance HasLogFunc Config where + logFuncL = runnerL.logFuncL +instance HasLogFunc LoadConfig where + logFuncL = runnerL.logFuncL +instance HasLogFunc BuildConfig where + logFuncL = runnerL.logFuncL +instance HasLogFunc EnvConfig where + logFuncL = runnerL.logFuncL + ----------------------------------- -- Helper lenses ----------------------------------- @@ -1870,28 +1954,21 @@ -- | The compiler specified by the @MiniBuildPlan@. This may be -- different from the actual compiler used! -wantedCompilerVersionL :: HasBuildConfig s => Lens' s CompilerVersion -wantedCompilerVersionL = miniBuildPlanL.lens - mbpCompilerVersion - (\x y -> x { mbpCompilerVersion = y }) +wantedCompilerVersionL :: HasBuildConfig s => Getting r s (CompilerVersion 'CVWanted) +wantedCompilerVersionL = snapshotDefL.to sdWantedCompilerVersion -- | The version of the compiler which will actually be used. May be -- different than that specified in the 'MiniBuildPlan' and returned -- by 'wantedCompilerVersionL'. -actualCompilerVersionL :: HasEnvConfig s => Lens' s CompilerVersion +actualCompilerVersionL :: HasEnvConfig s => Lens' s (CompilerVersion 'CVActual) actualCompilerVersionL = envConfigL.lens envConfigCompilerVersion (\x y -> x { envConfigCompilerVersion = y }) -loadedResolverL :: HasBuildConfig s => Lens' s LoadedResolver -loadedResolverL = buildConfigL.lens - bcResolver - (\x y -> x { bcResolver = y }) - -miniBuildPlanL :: HasBuildConfig s => Lens' s MiniBuildPlan -miniBuildPlanL = buildConfigL.lens - bcWantedMiniBuildPlan - (\x y -> x { bcWantedMiniBuildPlan = y }) +snapshotDefL :: HasBuildConfig s => Lens' s SnapshotDef +snapshotDefL = buildConfigL.lens + bcSnapshotDef + (\x y -> x { bcSnapshotDef = y }) packageIndicesL :: HasConfig s => Lens' s [PackageIndex] packageIndicesL = configL.lens @@ -1938,11 +2015,6 @@ configMonoidBuildOpts (\x y -> x { configMonoidBuildOpts = y }) -packageCachesL :: HasConfig env => Lens' env - (IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache) - ,HashMap GitSHA1 (PackageIndex, OffsetSize)))) -packageCachesL = configL.lens configPackageCaches (\x y -> x { configPackageCaches = y }) - configUrlsL :: HasConfig env => Lens' env Urls configUrlsL = configL.lens configUrls (\x y -> x { configUrls = y }) @@ -1951,5 +2023,29 @@ envConfigCabalVersion (\x y -> x { envConfigCabalVersion = y }) -whichCompilerL :: Getting r CompilerVersion WhichCompiler +loadedSnapshotL :: HasEnvConfig env => Lens' env LoadedSnapshot +loadedSnapshotL = envConfigL.lens + envConfigLoadedSnapshot + (\x y -> x { envConfigLoadedSnapshot = y }) + +whichCompilerL :: Getting r (CompilerVersion a) WhichCompiler whichCompilerL = to whichCompiler + +envOverrideL :: HasConfig env => Lens' env (EnvSettings -> IO EnvOverride) +envOverrideL = configL.lens + configEnvOverride + (\x y -> x { configEnvOverride = y }) + +shouldForceGhcColorFlag :: (HasRunner env, HasEnvConfig env) + => RIO env Bool +shouldForceGhcColorFlag = do + canDoColor <- (>= $(mkVersion "8.2.1")) . getGhcVersion + <$> view actualCompilerVersionL + shouldDoColor <- logUseColor <$> view logOptionsL + return $ canDoColor && shouldDoColor + +appropriateGhcColorFlag :: (HasRunner env, HasEnvConfig env) + => RIO env (Maybe String) +appropriateGhcColorFlag = f <$> shouldForceGhcColorFlag + where f True = Just ghcColorForceFlag + f False = Nothing diff --git a/src/Stack/Types/Config.hs-boot b/src/Stack/Types/Config.hs-boot deleted file mode 100644 --- a/src/Stack/Types/Config.hs-boot +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} - -module Stack.Types.Config where - -import Control.Exception -import Data.List.NonEmpty (NonEmpty) -import Distribution.Version -import Data.Text (Text) -import Data.Yaml (ParseException) -import Path -import Stack.Types.BuildPlan (SnapName) -import {-# SOURCE #-} Stack.Types.Resolver (Resolver, ResolverThat's) - -data WhichSolverCmd - -data ConfigException - = ParseConfigFileException (Path Abs File) ParseException - | ParseCustomSnapshotException Text ParseException - | ParseResolverException Text - | NoProjectConfigFound (Path Abs Dir) (Maybe Text) - | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File] - | UnableToExtractArchive Text (Path Abs File) - | BadStackVersionException VersionRange - | NoMatchingSnapshot WhichSolverCmd (NonEmpty SnapName) - | forall l. ResolverMismatch WhichSolverCmd (ResolverThat's l) String - | ResolverPartial WhichSolverCmd Resolver String - | NoSuchDirectory FilePath - | ParseGHCVariantException String - | BadStackRoot (Path Abs Dir) - | Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir) -- ^ @$STACK_ROOT@, parent dir - | UserDoesn'tOwnDirectory (Path Abs Dir) - | FailedToCloneRepo String - | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC - | NixRequiresSystemGhc - | NoResolverWhenUsingNoLocalConfig - | InvalidResolverForNoLocalConfig String -instance Exception ConfigException diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -27,15 +28,10 @@ ) where -import Control.Applicative import Data.Aeson.Extended -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Monoid -import Data.Text (Text) -import GHC.Generics (Generic) import Generics.Deriving.Monoid (memptydefault, mappenddefault) -import Prelude -- Fix AMP warning +import Stack.Prelude import Stack.Types.FlagName import Stack.Types.PackageName @@ -61,6 +57,8 @@ -- @hscolour@. Disable for no sources. ,boptsInstallExes :: !Bool -- ^ Install executables to user path after building? + ,boptsInstallCompilerTool :: !Bool + -- ^ Install executables to compiler tools path after building? ,boptsPreFetch :: !Bool -- ^ Fetch all packages immediately -- ^ Watch files for changes and automatically rebuild @@ -86,6 +84,8 @@ -- ^ Ask Cabal to be verbose in its builds ,boptsSplitObjs :: !Bool -- ^ Whether to enable split-objs. + ,boptsSkipComponents :: ![Text] + -- ^ Which components to skip when building } deriving (Show) @@ -102,6 +102,7 @@ , boptsHaddockInternal = False , boptsHaddockHyperlinkSource = True , boptsInstallExes = False + , boptsInstallCompilerTool = False , boptsPreFetch = False , boptsKeepGoing = Nothing , boptsForceDirty = False @@ -112,6 +113,7 @@ , boptsReconfigure = False , boptsCabalVerbose = False , boptsSplitObjs = False + , boptsSkipComponents = [] } defaultBuildOptsCLI ::BuildOptsCLI @@ -167,6 +169,7 @@ , buildMonoidHaddockInternal :: !(First Bool) , buildMonoidHaddockHyperlinkSource :: !(First Bool) , buildMonoidInstallExes :: !(First Bool) + , buildMonoidInstallCompilerTool :: !(First Bool) , buildMonoidPreFetch :: !(First Bool) , buildMonoidKeepGoing :: !(First Bool) , buildMonoidForceDirty :: !(First Bool) @@ -177,6 +180,7 @@ , buildMonoidReconfigure :: !(First Bool) , buildMonoidCabalVerbose :: !(First Bool) , buildMonoidSplitObjs :: !(First Bool) + , buildMonoidSkipComponents :: ![Text] } deriving (Show, Generic) instance FromJSON (WithJSONWarnings BuildOptsMonoid) where @@ -195,6 +199,7 @@ buildMonoidHaddockInternal <- First <$> o ..:? buildMonoidHaddockInternalArgName buildMonoidHaddockHyperlinkSource <- First <$> o ..:? buildMonoidHaddockHyperlinkSourceArgName buildMonoidInstallExes <- First <$> o ..:? buildMonoidInstallExesArgName + buildMonoidInstallCompilerTool <- First <$> o ..:? buildMonoidInstallCompilerToolArgName buildMonoidPreFetch <- First <$> o ..:? buildMonoidPreFetchArgName buildMonoidKeepGoing <- First <$> o ..:? buildMonoidKeepGoingArgName buildMonoidForceDirty <- First <$> o ..:? buildMonoidForceDirtyArgName @@ -205,6 +210,7 @@ buildMonoidReconfigure <- First <$> o ..:? buildMonoidReconfigureArgName buildMonoidCabalVerbose <- First <$> o ..:? buildMonoidCabalVerboseArgName buildMonoidSplitObjs <- First <$> o ..:? buildMonoidSplitObjsName + buildMonoidSkipComponents <- o ..:? buildMonoidSkipComponentsName ..!= mempty return BuildOptsMonoid{..}) buildMonoidLibProfileArgName :: Text @@ -240,6 +246,9 @@ buildMonoidInstallExesArgName :: Text buildMonoidInstallExesArgName = "copy-bins" +buildMonoidInstallCompilerToolArgName :: Text +buildMonoidInstallCompilerToolArgName = "copy-compiler-tool" + buildMonoidPreFetchArgName :: Text buildMonoidPreFetchArgName = "prefetch" @@ -269,6 +278,9 @@ buildMonoidSplitObjsName :: Text buildMonoidSplitObjsName = "split-objs" + +buildMonoidSkipComponentsName :: Text +buildMonoidSkipComponentsName = "skip-components" instance Monoid BuildOptsMonoid where mempty = memptydefault diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} @@ -8,22 +9,18 @@ module Stack.Types.Docker where -import Control.Applicative -import Control.Monad.Catch +import Stack.Prelude import Data.Aeson.Extended import Data.List (intercalate) -import Data.Monoid -import Data.Text (Text) import qualified Data.Text as T -import Data.Typeable import Distribution.System (Platform(..), OS(..), Arch(..)) import Distribution.Text (simpleParse, display) import Distribution.Version (anyVersion) -import GHC.Generics (Generic) import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Path -import {-# SOURCE #-} Stack.Constants +import Stack.Constants import Stack.Types.Version +import Text.Read (Read (..)) -- | Docker configuration. data DockerOpts = DockerOpts @@ -183,7 +180,11 @@ -- | For YAML. instance FromJSON Mount where - parseJSON v = fmap read (parseJSON v) + parseJSON v = do + s <- parseJSON v + case readMaybe s of + Nothing -> fail $ "Mount read failed: " ++ s + Just x -> return x -- | Options for Docker repository or image. data DockerMonoidRepoOrImage diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs --- a/src/Stack/Types/FlagName.hs +++ b/src/Stack/Types/FlagName.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} @@ -21,24 +22,14 @@ ,mkFlagName) where -import Control.Applicative -import Control.DeepSeq (NFData) -import Control.Monad.Catch +import Stack.Prelude import Data.Aeson.Extended -import Data.Attoparsec.Combinators -import Data.Attoparsec.Text +import Data.Attoparsec.Text as A import Data.Char (isLetter, isDigit, toLower) -import Data.Data -import Data.Hashable -import Data.Store (Store) -import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Binary () import qualified Distribution.PackageDescription as Cabal -import GHC.Generics import Language.Haskell.TH import Language.Haskell.TH.Syntax -import Stack.Types.StringError -- | A parse fail. newtype FlagNameParseFail @@ -80,13 +71,10 @@ -- | Attoparsec parser for a flag name flagNameParser :: Parser FlagName -flagNameParser = - fmap (FlagName . T.pack) - (appending (many1 (satisfy isLetter)) - (concating (many (alternating - (pured (satisfy isAlphaNum)) - (appending (pured (satisfy separator)) - (pured (satisfy isAlphaNum))))))) +flagNameParser = fmap FlagName $ do + t <- A.takeWhile1 (\c -> isAlphaNum c || separator c) + when (T.head t == '-') $ fail "flag name cannot start with dash" + return t where separator c = c == '-' || c == '_' isAlphaNum c = isLetter c || isDigit c @@ -94,7 +82,7 @@ mkFlagName :: String -> Q Exp mkFlagName s = case parseFlagNameFromString s of - Nothing -> errorString ("Invalid flag name: " ++ show s) + Nothing -> qRunIO $ throwString ("Invalid flag name: " ++ show s) Just pn -> [|pn|] -- | Convenient way to parse a flag name from a 'Text'. @@ -119,12 +107,12 @@ -- | Convert from a Cabal flag name. fromCabalFlagName :: Cabal.FlagName -> FlagName -fromCabalFlagName (Cabal.FlagName name) = - let !x = T.pack name +fromCabalFlagName name = + let !x = T.pack $ Cabal.unFlagName name in FlagName x -- | Convert to a Cabal flag name. toCabalFlagName :: FlagName -> Cabal.FlagName toCabalFlagName (FlagName name) = let !x = T.unpack name - in Cabal.FlagName x + in Cabal.mkFlagName x diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs --- a/src/Stack/Types/GhcPkgId.hs +++ b/src/Stack/Types/GhcPkgId.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -10,20 +11,10 @@ ,ghcPkgIdString) where -import Control.Applicative -import Control.DeepSeq -import Control.Monad.Catch +import Stack.Prelude import Data.Aeson.Extended import Data.Attoparsec.Text -import Data.Binary (Binary(..), putWord8, getWord8) -import Data.Binary.Tagged -import Data.Data -import Data.Hashable -import Data.Store -import Data.Text (Text) import qualified Data.Text as T -import GHC.Generics -import Prelude -- Fix AMP warning -- | A parse fail. newtype GhcPkgIdParseFail @@ -38,22 +29,7 @@ deriving (Eq,Ord,Data,Typeable,Generic) instance Hashable GhcPkgId -instance Binary GhcPkgId where - put (GhcPkgId x) = do - -- magic string - putWord8 1 - putWord8 3 - putWord8 4 - putWord8 7 - put x - get = do - 1 <- getWord8 - 3 <- getWord8 - 4 <- getWord8 - 7 <- getWord8 - fmap GhcPkgId get instance NFData GhcPkgId -instance HasStructuralInfo GhcPkgId instance Store GhcPkgId instance Show GhcPkgId where @@ -79,7 +55,8 @@ -- | A parser for a package-version-hash pair. ghcPkgIdParser :: Parser GhcPkgId ghcPkgIdParser = - GhcPkgId . T.pack <$> many1 (choice [digit, letter, satisfy (`elem` "_.-")]) + let elements = "_.-" :: String in + GhcPkgId . T.pack <$> many1 (choice [digit, letter, satisfy (`elem` elements)]) -- | Get a string representation of GHC package id. ghcPkgIdString :: GhcPkgId -> String diff --git a/src/Stack/Types/Image.hs b/src/Stack/Types/Image.hs --- a/src/Stack/Types/Image.hs +++ b/src/Stack/Types/Image.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,15 +8,10 @@ module Stack.Types.Image where import Data.Aeson.Extended -import Data.Monoid -import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (maybeToList) -import Data.Text (Text) -import GHC.Generics (Generic) import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Path -import Prelude -- Fix redundant import warnings +import Stack.Prelude -- | Image options. Currently only Docker image options. newtype ImageOpts = ImageOpts diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs deleted file mode 100644 --- a/src/Stack/Types/Internal.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE Rank2Types #-} - --- | Internal types to the library. - -module Stack.Types.Internal - ( Env (..) - , HasTerminal (..) - , HasReExec (..) - , Sticky (..) - , HasSticky (..) - , LogOptions (..) - , HasLogOptions (..) - , view - ) where - -import Control.Concurrent.MVar -import Control.Monad.Logger (LogLevel) -import Data.Text (Text) -import Lens.Micro -import Stack.Types.Config - --- | Monadic environment. -data Env config = - Env {envConfig :: !config - ,envReExec :: !Bool - ,envLogOptions :: !LogOptions - ,envTerminal :: !Bool - ,envSticky :: !Sticky - } - -envConfL :: Lens (Env a) (Env b) a b -envConfL = lens envConfig (\x y -> x { envConfig = y }) - -instance HasPlatform config => HasPlatform (Env config) where - platformL = envConfL.platformL - platformVariantL = envConfL.platformVariantL -instance HasGHCVariant config => HasGHCVariant (Env config) where - ghcVariantL = envConfL.ghcVariantL -instance HasConfig config => HasConfig (Env config) where - configL = envConfL.configL -instance HasBuildConfig config => HasBuildConfig (Env config) where - buildConfigL = envConfL.buildConfigL -instance HasEnvConfig config => HasEnvConfig (Env config) where - envConfigL = envConfL.envConfigL - -class HasTerminal env where - terminalL :: Lens' env Bool - -instance HasTerminal (Env config) where - terminalL = lens envTerminal (\x y -> x { envTerminal = y }) - -class HasReExec env where - reExecL :: Lens' env Bool - -instance HasReExec (Env config) where - reExecL = lens envReExec (\x y -> x { envReExec = y }) - -newtype Sticky = Sticky - { unSticky :: Maybe (MVar (Maybe Text)) - } - -class HasSticky env where - stickyL :: Lens' env Sticky - -instance HasSticky (Env config) where - stickyL = lens envSticky (\x y -> x { envSticky = y }) - -data LogOptions = LogOptions - { logUseColor :: Bool - , logUseUnicode :: Bool - , logUseTime :: Bool - , logMinLevel :: LogLevel - , logVerboseFormat :: Bool - } - -class HasLogOptions env where - logOptionsL :: Lens' env LogOptions - -instance HasLogOptions (Env config) where - logOptionsL = lens envLogOptions (\x y -> x { envLogOptions = y }) diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,13 +8,9 @@ module Stack.Types.Nix where -import Control.Applicative import Data.Aeson.Extended -import Data.Monoid -import Data.Text (Text) -import GHC.Generics (Generic) +import Stack.Prelude import Generics.Deriving.Monoid (mappenddefault, memptydefault) -import Prelude -- | Nix configuration. Parameterize by resolver type to avoid cyclic -- dependency. diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -8,62 +9,45 @@ {-# LANGUAGE ConstraintKinds #-} module Stack.Types.Package where -import Control.DeepSeq -import Control.Exception hiding (try,catch) +import Stack.Prelude import qualified Data.ByteString as S -import Data.Data -import Data.Function import Data.List import qualified Data.Map as M -import Data.Map.Strict (Map) -import Data.Maybe -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as Set -import Data.Store (Store) import Data.Store.Version (VersionConfig) import Data.Store.VersionTagged (storeVersionConfig) -import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Data.Word (Word64) import Distribution.InstalledPackageInfo (PError) import Distribution.License (License) import Distribution.ModuleName (ModuleName) -import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) import Distribution.PackageDescription (TestSuiteInterface, BuildType) import Distribution.System (Platform (..)) -import GHC.Generics (Generic) import Path as FL -import Prelude -import Stack.Types.BuildPlan (GitSHA1) +import Stack.Types.BuildPlan (PackageLocation, PackageLocationIndex (..), ExeName) import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.GhcPkgId import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.StackT (StackM) import Stack.Types.Version -- | All exceptions thrown by the library. data PackageException - = PackageInvalidCabalFile (Either (Path Abs File) PackageIdentifier) PError + = PackageInvalidCabalFile (Either PackageIdentifierRevision (Path Abs File)) PError | PackageNoCabalFileFound (Path Abs Dir) | PackageMultipleCabalFilesFound (Path Abs Dir) [Path Abs File] | MismatchedCabalName (Path Abs File) PackageName + | MismatchedCabalIdentifier !PackageIdentifierRevision !PackageIdentifier deriving Typeable instance Exception PackageException instance Show PackageException where - show (PackageInvalidCabalFile (Left file) err) = concat + show (PackageInvalidCabalFile loc err) = concat [ "Unable to parse cabal file " - , toFilePath file - , ": " - , show err - ] - show (PackageInvalidCabalFile (Right ident) err) = concat - [ "Unable to parse cabal file for " - , packageIdentifierString ident + , case loc of + Left pir -> "for " ++ packageIdentifierRevisionString pir + Right fp -> toFilePath fp , ": " , show err ] @@ -87,7 +71,21 @@ , ".cabal\n" , "For more information, see: https://github.com/commercialhaskell/stack/issues/317" ] + show (MismatchedCabalIdentifier pir ident) = concat + [ "Mismatched package identifier." + , "\nFound: " + , packageIdentifierString ident + , "\nExpected: " + , packageIdentifierRevisionString pir + ] +-- | Libraries in a package. Since Cabal 2.0, internal libraries are a +-- thing. +data PackageLibraries + = NoLibraries + | HasLibraries !(Set Text) -- ^ the foreign library names, sub libraries get built automatically without explicit component name passing + deriving (Show,Typeable) + -- | Some package info. data Package = Package {packageName :: !PackageName -- ^ Name of the package. @@ -95,12 +93,12 @@ ,packageLicense :: !License -- ^ The license the package was released under. ,packageFiles :: !GetPackageFiles -- ^ Get all files of the package. ,packageDeps :: !(Map PackageName VersionRange) -- ^ Packages that the package depends on. - ,packageTools :: ![Dependency] -- ^ A build tool name. + ,packageTools :: !(Map ExeName VersionRange) -- ^ A build tool name. ,packageAllDeps :: !(Set PackageName) -- ^ Original dependencies (not sieved). ,packageGhcOptions :: ![Text] -- ^ Ghc options used on package. ,packageFlags :: !(Map FlagName Bool) -- ^ Flags used on package. ,packageDefaultFlags :: !(Map FlagName Bool) -- ^ Defaults for unspecified flags. - ,packageHasLibrary :: !Bool -- ^ does the package have a buildable library stanza? + ,packageLibraries :: !PackageLibraries -- ^ does the package have a buildable library stanza? ,packageTests :: !(Map Text TestSuiteInterface) -- ^ names and interfaces of test suites ,packageBenchmarks :: !(Set Text) -- ^ names of benchmarks ,packageExes :: !(Set Text) -- ^ names of executables @@ -122,13 +120,14 @@ -- | Files that the package depends on, relative to package directory. -- Argument is the location of the .cabal file newtype GetPackageOpts = GetPackageOpts - { getPackageOpts :: forall env m. (StackM env m, HasEnvConfig env) + { getPackageOpts :: forall env. HasEnvConfig env => SourceMap -> InstalledMap -> [PackageName] -> [PackageName] -> Path Abs File - -> m (Map NamedComponent (Set ModuleName) + -> RIO env + (Map NamedComponent (Set ModuleName) ,Map NamedComponent (Set DotCabalPath) ,Map NamedComponent BuildInfoOpts) } @@ -154,9 +153,10 @@ -- | Files that the package depends on, relative to package directory. -- Argument is the location of the .cabal file newtype GetPackageFiles = GetPackageFiles - { getPackageFiles :: forall m env. (StackM env m, HasEnvConfig env) + { getPackageFiles :: forall env. HasEnvConfig env => Path Abs File - -> m (Map NamedComponent (Set ModuleName) + -> RIO env + (Map NamedComponent (Set ModuleName) ,Map NamedComponent (Set DotCabalPath) ,Set (Path Abs File) ,[PackageWarning]) @@ -182,7 +182,8 @@ ,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled? ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Configured flags. ,packageConfigGhcOptions :: ![Text] -- ^ Configured ghc options. - ,packageConfigCompilerVersion :: !CompilerVersion -- ^ GHC version + ,packageConfigCompilerVersion + :: !(CompilerVersion 'CVActual) -- ^ GHC version ,packageConfigPlatform :: !Platform -- ^ host platform } deriving (Show,Typeable) @@ -199,24 +200,24 @@ -- | Where the package's source is located: local directory or package index data PackageSource - = PSLocal LocalPackage - | PSUpstream Version InstallLocation (Map FlagName Bool) [Text] (Maybe GitSHA1) - -- ^ Upstream packages could be installed in either local or snapshot - -- databases; this is what 'InstallLocation' specifies. + = PSFiles LocalPackage InstallLocation + -- ^ Package which exist on the filesystem (as opposed to an index tarball) + | PSIndex InstallLocation (Map FlagName Bool) [Text] PackageIdentifierRevision + -- ^ Package which is in an index, and the files do not exist on the + -- filesystem yet. deriving Show -instance PackageInstallInfo PackageSource where - piiVersion (PSLocal lp) = packageVersion $ lpPackage lp - piiVersion (PSUpstream v _ _ _ _) = v +piiVersion :: PackageSource -> Version +piiVersion (PSFiles lp _) = packageVersion $ lpPackage lp +piiVersion (PSIndex _ _ _ (PackageIdentifierRevision (PackageIdentifier _ v) _)) = v - piiLocation (PSLocal _) = Local - piiLocation (PSUpstream _ loc _ _ _) = loc +piiLocation :: PackageSource -> InstallLocation +piiLocation (PSFiles _ loc) = loc +piiLocation (PSIndex loc _ _ _) = loc --- | Datatype which tells how which version of a package to install and where --- to install it into -class PackageInstallInfo a where - piiVersion :: a -> Version - piiLocation :: a -> InstallLocation +piiPackageLocation :: PackageSource -> PackageLocationIndex FilePath +piiPackageLocation (PSFiles lp _) = PLOther (lpLocation lp) +piiPackageLocation (PSIndex _ _ _ pir) = PLIndex pir -- | Information on a locally available package of source code data LocalPackage = LocalPackage @@ -228,7 +229,7 @@ , lpUnbuildable :: !(Set NamedComponent) -- ^ Components explicitly requested for build, that are marked -- "buildable: false". - , lpWanted :: !Bool + , lpWanted :: !Bool -- FIXME Should completely drop this "wanted" terminology, it's unclear -- ^ 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. @@ -251,17 +252,11 @@ -- ^ current state of the files , lpFiles :: !(Set (Path Abs File)) -- ^ all files used by this package + , lpLocation :: !(PackageLocation FilePath) + -- ^ Where this source code came from } deriving Show --- | A single, fully resolved component of a package -data NamedComponent - = CLib - | CExe !Text - | CTest !Text - | CBench !Text - deriving (Show, Eq, Ord) - renderComponent :: NamedComponent -> S.ByteString renderComponent CLib = "lib" renderComponent (CExe x) = "exe:" <> encodeUtf8 x @@ -398,11 +393,13 @@ type InstalledMap = Map PackageName (InstallLocation, Installed) -data Installed = Library PackageIdentifier GhcPkgId | Executable PackageIdentifier - deriving (Show, Eq, Ord) +data Installed + = Library PackageIdentifier GhcPkgId (Maybe License) + | Executable PackageIdentifier + deriving (Show, Eq) installedPackageIdentifier :: Installed -> PackageIdentifier -installedPackageIdentifier (Library pid _) = pid +installedPackageIdentifier (Library pid _ _) = pid installedPackageIdentifier (Executable pid) = pid -- | Get the installed Version. diff --git a/src/Stack/Types/PackageDump.hs b/src/Stack/Types/PackageDump.hs --- a/src/Stack/Types/PackageDump.hs +++ b/src/Stack/Types/PackageDump.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -8,13 +9,10 @@ , installedCacheVC ) where -import Data.Data -import Data.IORef -import Data.Map (Map) import Data.Store import Data.Store.Version import Data.Store.VersionTagged -import GHC.Generics (Generic) +import Stack.Prelude import Stack.Types.GhcPkgId import Stack.Types.PackageIdentifier diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -1,45 +1,66 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -fno-warn-unused-do-bind #-} -- | Package identifier (name-version). module Stack.Types.PackageIdentifier ( PackageIdentifier(..) + , PackageIdentifierRevision(..) + , CabalHash + , mkCabalHashFromSHA256 + , computeCabalHash + , showCabalHash + , CabalFileInfo(..) , toTuple , fromTuple , parsePackageIdentifier , parsePackageIdentifierFromString + , parsePackageIdentifierRevision , packageIdentifierParser , packageIdentifierString + , packageIdentifierRevisionString , packageIdentifierText - , toCabalPackageIdentifier ) + , toCabalPackageIdentifier + , fromCabalPackageIdentifier + , StaticSHA256 + , mkStaticSHA256FromText + , mkStaticSHA256FromFile + , mkStaticSHA256FromDigest + , staticSHA256ToText + , staticSHA256ToBase16 + , staticSHA256ToRaw + ) where -import Control.Applicative -import Control.DeepSeq -import Control.Exception (Exception) -import Control.Monad.Catch (MonadThrow, throwM) +import Stack.Prelude +import Crypto.Hash.Conduit (hashFile) +import Crypto.Hash as Hash (hashlazy, Digest, SHA256) import Data.Aeson.Extended -import Data.Attoparsec.Text -import Data.Data -import Data.Hashable -import Data.Store (Store) -import Data.Text (Text) +import Data.Attoparsec.Text as A +import qualified Data.ByteArray +import qualified Data.ByteArray.Encoding as Mem +import qualified Data.ByteString.Lazy as L import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import qualified Distribution.Package as C -import GHC.Generics -import Prelude hiding (FilePath) +import Stack.StaticBytes import Stack.Types.PackageName import Stack.Types.Version -- | A parse fail. -newtype PackageIdentifierParseFail +data PackageIdentifierParseFail = PackageIdentifierParseFail Text + | PackageIdentifierRevisionParseFail Text deriving (Typeable) instance Show PackageIdentifierParseFail where show (PackageIdentifierParseFail bs) = "Invalid package identifier: " ++ show bs + show (PackageIdentifierRevisionParseFail bs) = "Invalid package identifier (with optional revision): " ++ show bs instance Exception PackageIdentifierParseFail -- | A pkg-ver combination. @@ -68,6 +89,111 @@ Left e -> fail $ show (e, t) Right x -> return x +-- | A 'PackageIdentifier' combined with optionally specified Hackage +-- cabal file revision. +data PackageIdentifierRevision = PackageIdentifierRevision + { pirIdent :: !PackageIdentifier + , pirRevision :: !CabalFileInfo + } deriving (Eq,Ord,Generic,Data,Typeable) + +instance NFData PackageIdentifierRevision where + rnf (PackageIdentifierRevision !i !c) = + seq (rnf i) (rnf c) + +instance Hashable PackageIdentifierRevision +instance Store PackageIdentifierRevision + +instance Show PackageIdentifierRevision where + show = show . packageIdentifierRevisionString + +instance ToJSON PackageIdentifierRevision where + toJSON = toJSON . packageIdentifierRevisionString +instance FromJSON PackageIdentifierRevision where + parseJSON = withText "PackageIdentifierRevision" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show (e, t) + Right x -> return x + +-- | A cryptographic hash of a Cabal file. +newtype CabalHash = CabalHash { unCabalHash :: StaticSHA256 } + deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Store, Hashable) + +-- | A SHA256 hash, stored in a static size for more efficient +-- serialization with store. +newtype StaticSHA256 = StaticSHA256 Bytes32 + deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store) + +-- | Generate a 'StaticSHA256' value from a base16-encoded SHA256 hash. +mkStaticSHA256FromText :: Text -> Either SomeException StaticSHA256 +mkStaticSHA256FromText t = + mapLeft (toException . stringException) (Mem.convertFromBase Mem.Base16 (encodeUtf8 t)) + >>= either (Left . toE) (Right . StaticSHA256) + . toStaticExact + . (id :: ByteString -> ByteString) + where + toE e = toException $ stringException $ concat + [ "Unable to convert " + , show t + , " into SHA256: " + , show e + ] + +-- | Generate a 'StaticSHA256' value from the contents of a file. +mkStaticSHA256FromFile :: MonadIO m => Path Abs File -> m StaticSHA256 +mkStaticSHA256FromFile fp = liftIO $ mkStaticSHA256FromDigest <$> hashFile (toFilePath fp) + +mkStaticSHA256FromDigest :: Hash.Digest Hash.SHA256 -> StaticSHA256 +mkStaticSHA256FromDigest digest + = StaticSHA256 + $ either impureThrow id + $ toStaticExact + (Data.ByteArray.convert digest :: ByteString) + +-- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash. +staticSHA256ToText :: StaticSHA256 -> Text +staticSHA256ToText = decodeUtf8 . staticSHA256ToBase16 + +-- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash. +staticSHA256ToBase16 :: StaticSHA256 -> ByteString +staticSHA256ToBase16 (StaticSHA256 x) = Mem.convertToBase Mem.Base16 x + +staticSHA256ToRaw :: StaticSHA256 -> ByteString +staticSHA256ToRaw (StaticSHA256 x) = Data.ByteArray.convert x + +-- | Generate a 'CabalHash' value from a base16-encoded SHA256 hash. +mkCabalHashFromSHA256 :: Text -> Either SomeException CabalHash +mkCabalHashFromSHA256 = fmap CabalHash . mkStaticSHA256FromText + +-- | Convert a 'CabalHash' into a base16-encoded SHA256 hash. +cabalHashToText :: CabalHash -> Text +cabalHashToText = staticSHA256ToText . unCabalHash + +-- | Compute a 'CabalHash' value from a cabal file's contents. +computeCabalHash :: L.ByteString -> CabalHash +computeCabalHash = CabalHash . mkStaticSHA256FromDigest . Hash.hashlazy + +showCabalHash :: CabalHash -> Text +showCabalHash = T.append (T.pack "sha256:") . cabalHashToText + +-- | Information on the contents of a cabal file +data CabalFileInfo + = CFILatest + -- ^ Take the latest revision of the cabal file available. This + -- isn't reproducible at all, but the running assumption (not + -- necessarily true) is that cabal file revisions do not change + -- semantics of the build. + | CFIHash + !(Maybe Int) -- file size in bytes + !CabalHash + -- ^ Identify by contents of the cabal file itself + | CFIRevision !Word + -- ^ Identify by revision number, with 0 being the original and + -- counting upward. + deriving (Generic, Show, Eq, Ord, Data, Typeable) +instance Store CabalFileInfo +instance NFData CabalFileInfo +instance Hashable CabalFileInfo + -- | Convert from a package identifier to a tuple. toTuple :: PackageIdentifier -> (PackageName,Version) toTuple (PackageIdentifier n v) = (n,v) @@ -96,10 +222,55 @@ parsePackageIdentifierFromString = parsePackageIdentifier . T.pack +-- | Parse a 'PackageIdentifierRevision' +parsePackageIdentifierRevision :: MonadThrow m => Text -> m PackageIdentifierRevision +parsePackageIdentifierRevision x = go x + where + go = + either (const (throwM (PackageIdentifierRevisionParseFail x))) return . + parseOnly (parser <* endOfInput) + + parser = PackageIdentifierRevision + <$> packageIdentifierParser + <*> (cfiHash <|> cfiRevision <|> pure CFILatest) + + cfiHash = do + _ <- string $ T.pack "@sha256:" + hash' <- A.takeWhile (/= ',') + hash'' <- either (\e -> fail $ "Invalid SHA256: " ++ show e) return + $ mkCabalHashFromSHA256 hash' + msize <- optional $ do + _ <- A.char ',' + A.decimal + A.endOfInput + return $ CFIHash msize hash'' + + cfiRevision = do + _ <- string $ T.pack "@rev:" + y <- A.decimal + A.endOfInput + return $ CFIRevision y -- | Get a string representation of the package identifier; name-ver. packageIdentifierString :: PackageIdentifier -> String packageIdentifierString (PackageIdentifier n v) = show n ++ "-" ++ show v +-- | Get a string representation of the package identifier with revision; name-ver[@hashtype:hash[,size]]. +packageIdentifierRevisionString :: PackageIdentifierRevision -> String +packageIdentifierRevisionString (PackageIdentifierRevision ident cfi) = + concat $ packageIdentifierString ident : rest + where + rest = + case cfi of + CFILatest -> [] + CFIHash msize hash' -> + "@sha256:" + : T.unpack (cabalHashToText hash') + : showSize msize + CFIRevision rev -> ["@rev:", show rev] + + showSize Nothing = [] + showSize (Just int) = [',' : show int] + -- | Get a Text representation of the package identifier; name-ver. packageIdentifierText :: PackageIdentifier -> Text packageIdentifierText = T.pack . packageIdentifierString @@ -109,3 +280,9 @@ C.PackageIdentifier (toCabalPackageName (packageIdentifierName x)) (toCabalVersion (packageIdentifierVersion x)) + +fromCabalPackageIdentifier :: C.PackageIdentifier -> PackageIdentifier +fromCabalPackageIdentifier (C.PackageIdentifier name version) = + PackageIdentifier + (fromCabalPackageName name) + (fromCabalVersion version) diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs --- a/src/Stack/Types/PackageIndex.hs +++ b/src/Stack/Types/PackageIndex.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -10,7 +11,6 @@ ( PackageDownload (..) , HSPackageDownload (..) , PackageCache (..) - , PackageCacheMap (..) , OffsetSize (..) -- ** PackageIndex, IndexName & IndexLocation , PackageIndex(..) @@ -20,35 +20,39 @@ , HackageSecurity (..) ) where -import Control.DeepSeq (NFData) -import Control.Monad (mzero) import Data.Aeson.Extended -import Data.ByteString (ByteString) import qualified Data.Foldable as F -import Data.Hashable (Hashable) -import Data.Data (Data, Typeable) -import Data.HashMap.Strict (HashMap) -import Data.Int (Int64) -import Data.Map (Map) +import qualified Data.HashMap.Strict as HashMap import qualified Data.Map.Strict as Map -import Data.Store (Store) -import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Data.Word (Word64) -import GHC.Generics (Generic) import Path -import Stack.Types.BuildPlan (GitSHA1) +import Stack.Prelude +import Stack.Types.PackageName import Stack.Types.PackageIdentifier +import Stack.Types.Version +import Data.List.NonEmpty (NonEmpty) -data PackageCache = PackageCache - { pcOffsetSize :: {-# UNPACK #-}!OffsetSize - , pcDownload :: !(Maybe PackageDownload) - } - deriving (Generic, Eq, Show, Data, Typeable) +-- | Cached information about packages in an index. We have a mapping +-- from package name to a version map. Within the version map, we map +-- from the version to information on an individual version. Each +-- version has optional download information (about the package's +-- tarball itself), and cabal file information. The cabal file +-- information is a non-empty list of all cabal file revisions. Each +-- file revision indicates the hash of the contents of the cabal file, +-- and the offset into the index tarball. +-- +-- It's assumed that cabal files appear in the index tarball in the +-- correct revision order. +newtype PackageCache index = PackageCache + (HashMap PackageName + (HashMap Version + (index, Maybe PackageDownload, NonEmpty ([CabalHash], OffsetSize)))) + deriving (Generic, Eq, Show, Data, Typeable, Store, NFData) -instance Store PackageCache -instance NFData PackageCache +instance Monoid (PackageCache index) where + mempty = PackageCache HashMap.empty + mappend (PackageCache x) (PackageCache y) = PackageCache (HashMap.unionWith HashMap.union x y) -- | offset in bytes into the 01-index.tar file for the .cabal file -- contents, and size in bytes of the .cabal file @@ -58,28 +62,23 @@ instance Store OffsetSize instance NFData OffsetSize -data PackageCacheMap = PackageCacheMap - { pcmIdent :: !(Map PackageIdentifier PackageCache) - -- ^ most recent revision of the package - , pcmSHA :: !(HashMap GitSHA1 OffsetSize) - -- ^ lookup via the GitSHA1 of the cabal file contents - } - deriving (Generic, Eq, Show, Data, Typeable) -instance Store PackageCacheMap -instance NFData PackageCacheMap - data PackageDownload = PackageDownload - { pdSHA256 :: !ByteString + { pdSHA256 :: !StaticSHA256 , pdUrl :: !ByteString , pdSize :: !Word64 } deriving (Show, Generic, Eq, Data, Typeable) + instance Store PackageDownload instance NFData PackageDownload instance FromJSON PackageDownload where parseJSON = withObject "PackageDownload" $ \o -> do hashes <- o .: "package-hashes" - sha256 <- maybe mzero return (Map.lookup ("SHA256" :: Text) hashes) + sha256' <- maybe mzero return (Map.lookup ("SHA256" :: Text) hashes) + sha256 <- + case mkStaticSHA256FromText sha256' of + Left e -> fail $ "Invalid sha256: " ++ show e + Right x -> return x locs <- o .: "package-locations" url <- case reverse locs of @@ -87,7 +86,7 @@ x:_ -> return x size <- o .: "package-size" return PackageDownload - { pdSHA256 = encodeUtf8 sha256 + { pdSHA256 = sha256 , pdUrl = encodeUtf8 url , pdSize = size } @@ -102,9 +101,13 @@ Object o4:_ <- return $ F.toList o3 len <- o4 .: "length" hashes <- o4 .: "hashes" - sha256 <- hashes .: "sha256" + sha256' <- hashes .: "sha256" + sha256 <- + case mkStaticSHA256FromText sha256' of + Left e -> fail $ "Invalid sha256: " ++ show e + Right x -> return x return $ HSPackageDownload PackageDownload - { pdSHA256 = encodeUtf8 sha256 + { pdSHA256 = sha256 , pdSize = len , pdUrl = "" } diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} @@ -23,27 +24,17 @@ ,packageNameArgument) where -import Control.Applicative -import Control.DeepSeq -import Control.Monad -import Control.Monad.Catch +import Stack.Prelude import Data.Aeson.Extended import Data.Attoparsec.Combinators import Data.Attoparsec.Text -import Data.Data -import Data.Hashable import Data.List (intercalate) -import Data.Store (Store) -import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Binary () import qualified Distribution.Package as Cabal -import GHC.Generics import Language.Haskell.TH import Language.Haskell.TH.Syntax import qualified Options.Applicative as O import Path -import Stack.Types.StringError -- | A parse fail. data PackageNameParseFail @@ -96,7 +87,7 @@ mkPackageName :: String -> Q Exp mkPackageName s = case parsePackageNameFromString s of - Nothing -> errorString ("Invalid package name: " ++ show s) + Nothing -> qRunIO $ throwString ("Invalid package name: " ++ show s) Just pn -> [|pn|] -- | Parse a package name from a 'Text'. @@ -121,15 +112,15 @@ -- | Convert from a Cabal package name. fromCabalPackageName :: Cabal.PackageName -> PackageName -fromCabalPackageName (Cabal.PackageName name) = - let !x = T.pack name +fromCabalPackageName name = + let !x = T.pack $ Cabal.unPackageName name in PackageName x -- | Convert to a Cabal package name. toCabalPackageName :: PackageName -> Cabal.PackageName toCabalPackageName (PackageName name) = let !x = T.unpack name - in Cabal.PackageName x + in Cabal.mkPackageName x -- | Parse a package name from a file path. parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -1,134 +1,138 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Stack.Types.Resolver (Resolver ,IsLoaded(..) ,LoadedResolver - ,ResolverThat's(..) + ,ResolverWith(..) ,parseResolverText - ,resolverDirName - ,resolverName - ,customResolverHash - ,toResolverNotLoaded ,AbstractResolver(..) ,readAbstractResolver + ,resolverRawName + ,SnapName(..) + ,Snapshots (..) + ,renderSnapName + ,parseSnapName + ,SnapshotHash + ,trimmedSnapshotHash + ,snapshotHashToBS + ,snapshotHashFromBS + ,snapshotHashFromDigest + ,parseCustomLocation ) where -import Control.Applicative -import Control.Monad.Catch (MonadThrow, throwM) +import Crypto.Hash as Hash (hash, Digest, SHA256) import Data.Aeson.Extended - (ToJSON, toJSON, FromJSON, parseJSON, object, - WithJSONWarnings(..), Value(String, Object), (.=), - noJSONWarnings, (..:), withObjectWarnings) -import Data.Monoid.Extra -import Data.Text (Text) + (ToJSON, toJSON, FromJSON, parseJSON, + withObject, (.:), withText) +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64.URL as B64URL +import qualified Data.HashMap.Strict as HashMap +import qualified Data.IntMap.Strict as IntMap import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Text.Read (decimal) +import Data.Time (Day) +import Network.HTTP.Client (Request, parseUrlThrow) import Options.Applicative (ReadM) -import qualified Options.Applicative as OA import qualified Options.Applicative.Types as OA -import Prelude -import Stack.Types.BuildPlan (parseSnapName, renderSnapName, SnapName, SnapshotHash, - trimmedSnapshotHash) -import {-# SOURCE #-} Stack.Types.Config (ConfigException(..)) +import Path +import Stack.Prelude import Stack.Types.Compiler +import Stack.Types.PackageIdentifier +import qualified System.FilePath as FP data IsLoaded = Loaded | NotLoaded -type LoadedResolver = ResolverThat's 'Loaded -type Resolver = ResolverThat's 'NotLoaded +type LoadedResolver = ResolverWith SnapshotHash +type Resolver = ResolverWith (Either Request FilePath) -- TODO: once GHC 8.0 is the lowest version we support, make these into -- actual haddock comments... -- | How we resolve which dependencies to install given a set of packages. -data ResolverThat's (l :: IsLoaded) where - -- Use an official snapshot from the Stackage project, either an LTS - -- Haskell or Stackage Nightly. - ResolverSnapshot :: !SnapName -> ResolverThat's l - -- Require a specific compiler version, but otherwise provide no +data ResolverWith customContents + = ResolverSnapshot !SnapName -- FIXME rename to ResolverStackage + -- ^ Use an official snapshot from the Stackage project, either an + -- LTS Haskell or Stackage Nightly. + + | ResolverCompiler !(CompilerVersion 'CVWanted) + -- ^ Require a specific compiler version, but otherwise provide no -- build plan. Intended for use cases where end user wishes to -- specify all upstream dependencies manually, such as using a -- dependency solver. - ResolverCompiler :: !CompilerVersion -> ResolverThat's l - -- A custom resolver based on the given name and URL. When a URL is - -- provided, its contents must be completely immutable. Filepaths are - -- always loaded. This constructor is used before the build-plan has - -- been loaded, as we do not yet know the custom snapshot's hash. - ResolverCustom :: !Text -> !Text -> ResolverThat's 'NotLoaded - -- Like 'ResolverCustom', but after loading the build-plan, so we - -- have a hash. This is necessary in order to identify the location - -- files are stored for the resolver. - ResolverCustomLoaded :: !Text -> !Text -> !SnapshotHash -> ResolverThat's 'Loaded -deriving instance Eq (ResolverThat's k) -deriving instance Show (ResolverThat's k) + | ResolverCustom !Text !customContents + -- ^ A custom resolver based on the given location (as a raw URL + -- or filepath). If @customContents@ is a @Either Request + -- FilePath@, it represents the parsed location value (with + -- filepaths resolved relative to the directory containing the + -- file referring to the custom snapshot). Once it has been loaded + -- from disk, it will be replaced with a @SnapshotHash@ value, + -- which is used to store cached files. + deriving (Generic, Typeable, Show, Data, Eq, Functor, Foldable, Traversable) +instance Store LoadedResolver +instance NFData LoadedResolver -instance ToJSON (ResolverThat's k) where +instance ToJSON (ResolverWith a) where toJSON x = case x of - ResolverSnapshot{} -> toJSON $ resolverName x - ResolverCompiler{} -> toJSON $ resolverName x - ResolverCustom n l -> handleCustom n l - ResolverCustomLoaded n l _ -> handleCustom n l - where - handleCustom n l = object - [ "name" .= n - , "location" .= l - ] -instance FromJSON (WithJSONWarnings (ResolverThat's 'NotLoaded)) where - -- Strange structuring is to give consistent error messages - parseJSON v@(Object _) = withObjectWarnings "Resolver" (\o -> ResolverCustom - <$> o ..: "name" - <*> o ..: "location") v - - parseJSON (String t) = either (fail . show) return (noJSONWarnings <$> parseResolverText t) - - parseJSON _ = fail "Invalid Resolver, must be Object or String" - --- | Convert a Resolver into its @Text@ representation, as will be used by --- directory names -resolverDirName :: LoadedResolver -> Text -resolverDirName (ResolverSnapshot name) = renderSnapName name -resolverDirName (ResolverCompiler v) = compilerVersionText v -resolverDirName (ResolverCustomLoaded name _ hash) = "custom-" <> name <> "-" <> decodeUtf8 (trimmedSnapshotHash hash) + ResolverSnapshot name -> toJSON $ renderSnapName name + ResolverCompiler version -> toJSON $ compilerVersionText version + ResolverCustom loc _ -> toJSON loc +instance a ~ () => FromJSON (ResolverWith a) where + parseJSON = withText "ResolverWith ()" $ return . parseResolverText -- | Convert a Resolver into its @Text@ representation for human --- presentation. -resolverName :: ResolverThat's l -> Text -resolverName (ResolverSnapshot name) = renderSnapName name -resolverName (ResolverCompiler v) = compilerVersionText v -resolverName (ResolverCustom name _) = "custom-" <> name -resolverName (ResolverCustomLoaded name _ _) = "custom-" <> name +-- presentation. When possible, you should prefer @sdResolverName@, as +-- it will handle the human-friendly name inside a custom snapshot. +resolverRawName :: ResolverWith a -> Text +resolverRawName (ResolverSnapshot name) = renderSnapName name +resolverRawName (ResolverCompiler v) = compilerVersionText v +resolverRawName (ResolverCustom loc _ ) = "custom: " <> loc -customResolverHash :: LoadedResolver-> Maybe SnapshotHash -customResolverHash (ResolverCustomLoaded _ _ hash) = Just hash -customResolverHash _ = Nothing +parseCustomLocation + :: MonadThrow m + => Maybe (Path Abs Dir) -- ^ directory config value was read from + -> ResolverWith () -- could technically be any type parameter, restricting to help with type safety + -> m Resolver +parseCustomLocation mdir (ResolverCustom t ()) = + ResolverCustom t <$> case parseUrlThrow $ T.unpack t of + Nothing -> Right <$> do + dir <- + case mdir of + Nothing -> throwM $ FilepathInDownloadedSnapshot t + Just x -> return x + let rel = + T.unpack + $ fromMaybe t + $ T.stripPrefix "file://" t <|> T.stripPrefix "file:" t + return $ toFilePath dir FP. rel + Just req -> return $ Left req +parseCustomLocation _ (ResolverSnapshot name) = return $ ResolverSnapshot name +parseCustomLocation _ (ResolverCompiler cv) = return $ ResolverCompiler cv --- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom). -parseResolverText :: MonadThrow m => Text -> m Resolver +-- | Parse a @Resolver@ from a @Text@ +parseResolverText :: Text -> ResolverWith () parseResolverText t - | Right x <- parseSnapName t = return $ ResolverSnapshot x - | Just v <- parseCompilerVersion t = return $ ResolverCompiler v - | otherwise = throwM $ ParseResolverException t - -toResolverNotLoaded :: LoadedResolver -> Resolver -toResolverNotLoaded r = case r of - ResolverSnapshot s -> ResolverSnapshot s - ResolverCompiler v -> ResolverCompiler v - ResolverCustomLoaded n l _ -> ResolverCustom n l + | Right x <- parseSnapName t = ResolverSnapshot x + | Just v <- parseCompilerVersion t = ResolverCompiler v + | otherwise = ResolverCustom t () -- | Either an actual resolver value, or an abstract description of one (e.g., -- latest nightly). @@ -136,7 +140,7 @@ = ARLatestNightly | ARLatestLTS | ARLatestLTSMajor !Int - | ARResolver !Resolver + | ARResolver !(ResolverWith ()) | ARGlobal deriving Show @@ -149,7 +153,104 @@ "lts" -> return ARLatestLTS 'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x -> return $ ARLatestLTSMajor x' - _ -> - case parseResolverText $ T.pack s of - Left e -> OA.readerError $ show e - Right x -> return $ ARResolver x + _ -> return $ ARResolver $ parseResolverText $ T.pack s + +-- | The name of an LTS Haskell or Stackage Nightly snapshot. +data SnapName + = LTS !Int !Int + | Nightly !Day + deriving (Generic, Typeable, Show, Data, Eq) +instance Store SnapName +instance NFData SnapName + +data BuildPlanTypesException + = ParseSnapNameException !Text + | ParseResolverException !Text + | FilepathInDownloadedSnapshot !Text + deriving Typeable +instance Exception BuildPlanTypesException +instance Show BuildPlanTypesException where + show (ParseSnapNameException t) = "Invalid snapshot name: " ++ T.unpack t + show (ParseResolverException t) = concat + [ "Invalid resolver value: " + , T.unpack t + , ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, ghc-7.10.2, and ghcjs-0.1.0_ghc-7.10.2. " + , "See https://www.stackage.org/snapshots for a complete list." + ] + show (FilepathInDownloadedSnapshot url) = unlines + [ "Downloaded snapshot specified a 'resolver: { location: filepath }' " + , "field, but filepaths are not allowed in downloaded snapshots.\n" + , "Filepath specified: " ++ T.unpack url + ] + +-- | Convert a 'SnapName' into its short representation, e.g. @lts-2.8@, +-- @nightly-2015-03-05@. +renderSnapName :: SnapName -> Text +renderSnapName (LTS x y) = T.pack $ concat ["lts-", show x, ".", show y] +renderSnapName (Nightly d) = T.pack $ "nightly-" ++ show d + +-- | Parse the short representation of a 'SnapName'. +parseSnapName :: MonadThrow m => Text -> m SnapName +parseSnapName t0 = + case lts <|> nightly of + Nothing -> throwM $ ParseSnapNameException t0 + Just sn -> return sn + where + lts = do + t1 <- T.stripPrefix "lts-" t0 + Right (x, t2) <- Just $ decimal t1 + t3 <- T.stripPrefix "." t2 + Right (y, "") <- Just $ decimal t3 + return $ LTS x y + nightly = do + t1 <- T.stripPrefix "nightly-" t0 + Nightly <$> readMaybe (T.unpack t1) + +-- | Most recent Nightly and newest LTS version per major release. +data Snapshots = Snapshots + { snapshotsNightly :: !Day + , snapshotsLts :: !(IntMap Int) + } + deriving Show +instance FromJSON Snapshots where + parseJSON = withObject "Snapshots" $ \o -> Snapshots + <$> (o .: "nightly" >>= parseNightly) + <*> fmap IntMap.unions (mapM (parseLTS . snd) + $ filter (isLTS . fst) + $ HashMap.toList o) + where + parseNightly t = + case parseSnapName t of + Left e -> fail $ show e + Right (LTS _ _) -> fail "Unexpected LTS value" + Right (Nightly d) -> return d + + isLTS = ("lts-" `T.isPrefixOf`) + + parseLTS = withText "LTS" $ \t -> + case parseSnapName t of + Left e -> fail $ show e + Right (LTS x y) -> return $ IntMap.singleton x y + Right (Nightly _) -> fail "Unexpected nightly value" + +newtype SnapshotHash = SnapshotHash { unSnapshotHash :: StaticSHA256 } + deriving (Generic, Typeable, Show, Data, Eq) +instance Store SnapshotHash +instance NFData SnapshotHash + +-- | Return the first 12 characters of the hash as a B64URL-encoded +-- string. +trimmedSnapshotHash :: SnapshotHash -> Text +trimmedSnapshotHash = decodeUtf8 . B.take 12 . B64URL.encode . staticSHA256ToRaw . unSnapshotHash + +-- | Return the raw bytes in the hash +snapshotHashToBS :: SnapshotHash -> ByteString +snapshotHashToBS = staticSHA256ToRaw . unSnapshotHash + +-- | Create a new SnapshotHash by SHA256 hashing the given contents +snapshotHashFromBS :: ByteString -> SnapshotHash +snapshotHashFromBS = snapshotHashFromDigest . Hash.hash + +-- | Create a new SnapshotHash from the given digest +snapshotHashFromDigest :: Digest SHA256 -> SnapshotHash +snapshotHashFromDigest = SnapshotHash . mkStaticSHA256FromDigest diff --git a/src/Stack/Types/Resolver.hs-boot b/src/Stack/Types/Resolver.hs-boot deleted file mode 100644 --- a/src/Stack/Types/Resolver.hs-boot +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE GADTs #-} - -module Stack.Types.Resolver where - -import Data.Text (Text) -import Stack.Types.BuildPlan (SnapName, SnapshotHash) -import Stack.Types.Compiler - -data IsLoaded = Loaded | NotLoaded - -data ResolverThat's (l :: IsLoaded) where - ResolverSnapshot :: !SnapName -> ResolverThat's l - ResolverCompiler :: !CompilerVersion -> ResolverThat's l - ResolverCustom :: !Text -> !Text -> ResolverThat's 'NotLoaded - ResolverCustomLoaded :: !Text -> !Text -> !SnapshotHash -> ResolverThat's 'Loaded - -type LoadedResolver = ResolverThat's 'Loaded - -type Resolver = ResolverThat's 'NotLoaded diff --git a/src/Stack/Types/Runner.hs b/src/Stack/Types/Runner.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/Runner.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Run environment + +module Stack.Types.Runner + ( Runner (..) + , HasRunner (..) + , terminalL + , reExecL + , stickyL + , logOptionsL + , Sticky (..) + , LogOptions (..) + , ColorWhen (..) + , withRunner + ) where + +import qualified Data.ByteString.Char8 as S8 +import Data.Char +import Data.List (stripPrefix) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import qualified Data.Text.IO as T +import Data.Time +import Distribution.PackageDescription (GenericPackageDescription) +import GHC.Foreign (peekCString, withCString) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (lift) +import Lens.Micro +import Stack.Prelude hiding (lift) +import Stack.Constants +import Stack.Types.PackageIdentifier (PackageIdentifierRevision) +import System.Console.ANSI +import System.FilePath +import System.IO +import System.Log.FastLogger +import System.Terminal + +-- | Monadic environment. +data Runner = Runner + { runnerReExec :: !Bool + , runnerLogOptions :: !LogOptions + , runnerTerminal :: !Bool + , runnerSticky :: !Sticky + , runnerParsedCabalFiles :: !(IORef + ( Map PackageIdentifierRevision GenericPackageDescription + , Map (Path Abs Dir) (GenericPackageDescription, Path Abs File) + )) + -- ^ Cache of previously parsed cabal files. + -- + -- TODO: This is really an ugly hack to avoid spamming the user with + -- warnings when we parse cabal files multiple times and bypass + -- performance issues. Ideally: we would just design the system such + -- that it only ever parses a cabal file once. But for now, this is + -- a decent workaround. See: + -- . + } + +class HasLogFunc env => HasRunner env where + runnerL :: Lens' env Runner +instance HasRunner Runner where + runnerL = id + +terminalL :: HasRunner env => Lens' env Bool +terminalL = runnerL.lens runnerTerminal (\x y -> x { runnerTerminal = y }) + +reExecL :: HasRunner env => Lens' env Bool +reExecL = runnerL.lens runnerReExec (\x y -> x { runnerReExec = y }) + +stickyL :: HasRunner env => Lens' env Sticky +stickyL = runnerL.lens runnerSticky (\x y -> x { runnerSticky = y }) + +logOptionsL :: HasRunner env => Lens' env LogOptions +logOptionsL = runnerL.lens runnerLogOptions (\x y -> x { runnerLogOptions = y }) + +newtype Sticky = Sticky + { unSticky :: Maybe (MVar (Maybe Text)) + } + +data LogOptions = LogOptions + { logUseColor :: Bool + , logTermWidth :: Int + , logUseUnicode :: Bool + , logUseTime :: Bool + , logMinLevel :: LogLevel + , logVerboseFormat :: Bool + } + +-------------------------------------------------------------------------------- +-- Logging functionality + +instance HasLogFunc Runner where + logFuncL = to $ \env -> stickyLoggerFuncImpl (view stickyL env) (view logOptionsL env) + +stickyLoggerFuncImpl + :: ToLogStr msg + => Sticky -> LogOptions + -> (Loc -> LogSource -> LogLevel -> msg -> IO ()) +stickyLoggerFuncImpl (Sticky mref) lo loc src level msg = + case mref of + Nothing -> + loggerFunc + lo + out + loc + src + (case level of + LevelOther "sticky-done" -> LevelInfo + LevelOther "sticky" -> LevelInfo + _ -> level) + msg + Just ref -> modifyMVar_ ref $ \sticky -> do + let backSpaceChar = '\8' + repeating = S8.replicate (maybe 0 T.length sticky) + clear = S8.hPutStr out + (repeating backSpaceChar <> + repeating ' ' <> + repeating backSpaceChar) + + -- Convert some GHC-generated Unicode characters as necessary + let msgText + | logUseUnicode lo = msgTextRaw + | otherwise = T.map replaceUnicode msgTextRaw + + case level of + LevelOther "sticky-done" -> do + clear + T.hPutStrLn out msgText + hFlush out + return Nothing + LevelOther "sticky" -> do + clear + T.hPutStr out msgText + hFlush out + return (Just msgText) + _ + | level >= logMinLevel lo -> do + clear + loggerFunc lo out loc src level $ toLogStr msgText + case sticky of + Nothing -> + return Nothing + Just line -> do + T.hPutStr out line >> hFlush out + return sticky + | otherwise -> + return sticky + where + out = stderr + msgTextRaw = T.decodeUtf8With T.lenientDecode msgBytes + msgBytes = fromLogStr (toLogStr msg) + +-- | Replace Unicode characters with non-Unicode equivalents +replaceUnicode :: Char -> Char +replaceUnicode '\x2018' = '`' +replaceUnicode '\x2019' = '\'' +replaceUnicode c = c + +-- | Logging function takes the log level into account. +loggerFunc :: ToLogStr msg + => LogOptions -> Handle -> Loc -> Text -> LogLevel -> msg -> IO () +loggerFunc lo outputChannel loc _src level msg = + when (level >= logMinLevel lo) + (liftIO (do out <- getOutput + T.hPutStrLn outputChannel out)) + where + getOutput = do + timestamp <- getTimestamp + l <- getLevel + lc <- getLoc + return $ T.concat + [ T.pack timestamp + , T.pack l + , T.pack (ansi [Reset]) + , T.decodeUtf8 (fromLogStr (toLogStr msg)) + , T.pack lc + , T.pack (ansi [Reset]) + ] + where + ansi xs | logUseColor lo = setSGRCode xs + | otherwise = "" + getTimestamp + | logVerboseFormat lo && logUseTime lo = + do now <- getZonedTime + return $ + ansi [SetColor Foreground Vivid Black] + ++ formatTime' now ++ ": " + | otherwise = return "" + where + formatTime' = + take timestampLength . formatTime defaultTimeLocale "%F %T.%q" + getLevel + | logVerboseFormat lo = + return ((case level of + LevelDebug -> ansi [SetColor Foreground Dull Green] + LevelInfo -> ansi [SetColor Foreground Dull Blue] + LevelWarn -> ansi [SetColor Foreground Dull Yellow] + LevelError -> ansi [SetColor Foreground Dull Red] + LevelOther _ -> ansi [SetColor Foreground Dull Magenta]) ++ + "[" ++ + map toLower (drop 5 (show level)) ++ + "] ") + | otherwise = return "" + getLoc + | logVerboseFormat lo = + return $ + ansi [SetColor Foreground Vivid Black] ++ + "\n@(" ++ fileLocStr ++ ")" + | otherwise = return "" + fileLocStr = + fromMaybe file (stripPrefix dirRoot file) ++ + ':' : + line loc ++ + ':' : + char loc + where + file = loc_filename loc + line = show . fst . loc_start + char = show . snd . loc_start + dirRoot = $(lift . T.unpack . fromMaybe undefined . T.stripSuffix (T.pack $ "Stack" "Types" "Runner.hs") . T.pack . loc_filename =<< location) + +-- | 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 = + if terminal + then do state <- liftIO (newMVar Nothing) + originalMode <- liftIO (hGetBuffering stdout) + liftIO (hSetBuffering stdout NoBuffering) + a <- m (Sticky (Just state)) + state' <- liftIO (takeMVar state) + liftIO (when (isJust state') (S8.putStr "\n")) + liftIO (hSetBuffering stdout originalMode) + return a + else m (Sticky Nothing) + +-- | With a 'Runner', do the thing +withRunner :: MonadIO m + => LogLevel + -> Bool -- ^ use time? + -> Bool -- ^ terminal? + -> ColorWhen + -> Maybe Int -- ^ terminal width override + -> Bool -- ^ reexec? + -> (Runner -> m a) + -> m a +withRunner logLevel useTime terminal colorWhen widthOverride reExec inner = do + useColor <- case colorWhen of + ColorNever -> return False + ColorAlways -> return True + ColorAuto -> liftIO $ hSupportsANSI stderr + termWidth <- clipWidth <$> maybe (fromMaybe defaultTerminalWidth + <$> liftIO getTerminalWidth) + pure widthOverride + canUseUnicode <- liftIO getCanUseUnicode + ref <- newIORef mempty + withSticky terminal $ \sticky -> inner Runner + { runnerReExec = reExec + , runnerLogOptions = LogOptions + { logUseColor = useColor + , logTermWidth = termWidth + , logUseUnicode = canUseUnicode + , logUseTime = useTime + , logMinLevel = logLevel + , logVerboseFormat = logLevel <= LevelDebug + } + , runnerTerminal = terminal + , runnerSticky = sticky + , runnerParsedCabalFiles = ref + } + where clipWidth w + | w < minTerminalWidth = minTerminalWidth + | w > maxTerminalWidth = maxTerminalWidth + | otherwise = w + +-- | Taken from GHC: determine if we should use Unicode syntax +getCanUseUnicode :: IO Bool +getCanUseUnicode = do + let enc = localeEncoding + str = "\x2018\x2019" + test = withCString enc str $ \cstr -> do + str' <- peekCString enc cstr + return (str == str') + test `catchIO` \_ -> return False + +data ColorWhen = ColorNever | ColorAlways | ColorAuto + deriving (Show, Generic) diff --git a/src/Stack/Types/Sig.hs b/src/Stack/Types/Sig.hs --- a/src/Stack/Types/Sig.hs +++ b/src/Stack/Types/Sig.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -15,19 +16,11 @@ module Stack.Types.Sig (Signature(..), Fingerprint, mkFingerprint, SigException(..)) where -import Prelude () -import Prelude.Compat - -import Control.Exception (Exception) +import Stack.Prelude import Data.Aeson (Value(..), ToJSON(..), FromJSON(..)) -import Data.ByteString (ByteString) import qualified Data.ByteString as SB import Data.Char (isHexDigit) -import Data.Monoid ((<>)) -import Data.String (IsString(..)) -import Data.Text (Text) import qualified Data.Text as T -import Data.Typeable (Typeable) import Stack.Types.PackageName -- | A GPG signature. diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs deleted file mode 100644 --- a/src/Stack/Types/StackT.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ConstraintKinds #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | The monad used for the command-line executable @stack@. - -module Stack.Types.StackT - (StackT - ,HasEnv - ,StackM - ,runStackT - ,runStackTGlobal - ,runInnerStackT - ,logSticky - ,logStickyDone) - where - -import Control.Applicative -import Control.Concurrent.MVar -import Control.Monad -import Control.Monad.Base -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Reader hiding (lift) -import Control.Monad.Trans.Control -import qualified Data.ByteString.Char8 as S8 -import Data.Char -import Data.List (stripPrefix) -import Data.Maybe -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -import qualified Data.Text.IO as T -import Data.Time -import GHC.Foreign (withCString, peekCString) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (lift) -import Prelude -- Fix AMP warning -import Stack.Types.Config (GlobalOpts (..), ColorWhen(..)) -import Stack.Types.Internal -import System.Console.ANSI -import System.FilePath -import System.IO -import System.Log.FastLogger - -#ifndef MIN_VERSION_time -#define MIN_VERSION_time(x, y, z) 0 -#endif -#if !MIN_VERSION_time(1, 5, 0) -import System.Locale -#endif - --- | Constraint synonym for all of the common environment instances -type HasEnv r = (HasLogOptions r, HasTerminal r, HasReExec r, HasSticky r) - --- | Constraint synonym for constraints commonly satisifed by monads used in stack. -type StackM r m = - (MonadReader r m, MonadIO m, MonadBaseControl IO m, MonadLoggerIO m, MonadMask m, HasEnv r) - --------------------------------------------------------------------------------- --- Main StackT monad transformer - --- | The monad used for the executable @stack@. -newtype StackT config m a = - StackT {unStackT :: ReaderT (Env config) m a} - deriving (Functor,Applicative,Monad,MonadIO,MonadReader (Env config),MonadThrow,MonadCatch,MonadMask,MonadTrans) - -deriving instance (MonadBase b m) => MonadBase b (StackT config m) - -instance MonadBaseControl b m => MonadBaseControl b (StackT config m) where - type StM (StackT config m) a = ComposeSt (StackT config) m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - -instance MonadTransControl (StackT config) where - type StT (StackT config) a = StT (ReaderT (Env config)) a - liftWith = defaultLiftWith StackT unStackT - restoreT = defaultRestoreT StackT - --- | Takes the configured log level into account. -instance MonadIO m => MonadLogger (StackT config m) where - monadLoggerLog = stickyLoggerFunc - -instance MonadIO m => MonadLoggerIO (StackT config m) where - askLoggerIO = getStickyLoggerFunc - --- | Run a Stack action, using global options. -runStackTGlobal :: (MonadIO m) - => config -> GlobalOpts -> StackT config m a -> m a -runStackTGlobal config GlobalOpts{..} = - runStackT config globalLogLevel globalTimeInLog globalTerminal globalColorWhen (isJust globalReExecVersion) - -runStackT :: (MonadIO m) - => config -> LogLevel -> Bool -> Bool -> ColorWhen -> Bool -> StackT config m a -> m a -runStackT config logLevel useTime terminal colorWhen reExec m = do - useColor <- case colorWhen of - ColorNever -> return False - ColorAlways -> return True - ColorAuto -> liftIO $ hSupportsANSI stderr - canUseUnicode <- liftIO getCanUseUnicode - withSticky terminal $ \sticky -> runReaderT (unStackT m) Env - { envConfig = config - , envReExec = reExec - , envLogOptions = LogOptions - { logUseColor = useColor - , logUseUnicode = canUseUnicode - , logUseTime = useTime - , logMinLevel = logLevel - , logVerboseFormat = logLevel <= LevelDebug - } - , envTerminal = terminal - , envSticky = sticky - } - --- | Taken from GHC: determine if we should use Unicode syntax -getCanUseUnicode :: IO Bool -getCanUseUnicode = do - let enc = localeEncoding - str = "\x2018\x2019" - test = withCString enc str $ \cstr -> do - str' <- peekCString enc cstr - return (str == str') - test `catchIOError` \_ -> return False - -runInnerStackT :: (HasEnv r, MonadReader r m, MonadIO m) - => config -> StackT config IO a -> m a -runInnerStackT config inner = do - reExec <- view reExecL - logOptions <- view logOptionsL - terminal <- view terminalL - sticky <- view stickyL - liftIO $ runReaderT (unStackT inner) Env - { envConfig = config - , envReExec = reExec - , envLogOptions = logOptions - , envTerminal = terminal - , envSticky = sticky - } - --------------------------------------------------------------------------------- --- Logging functionality -stickyLoggerFunc - :: (HasEnv r, ToLogStr msg, MonadReader r m, MonadIO m) - => Loc -> LogSource -> LogLevel -> msg -> m () -stickyLoggerFunc loc src level msg = do - func <- getStickyLoggerFunc - liftIO $ func loc src level msg - -getStickyLoggerFunc - :: (HasEnv r, ToLogStr msg, MonadReader r m) - => m (Loc -> LogSource -> LogLevel -> msg -> IO ()) -getStickyLoggerFunc = do - sticky <- view stickyL - lo <- view logOptionsL - return $ stickyLoggerFuncImpl sticky lo - -stickyLoggerFuncImpl - :: ToLogStr msg - => Sticky -> LogOptions - -> (Loc -> LogSource -> LogLevel -> msg -> IO ()) -stickyLoggerFuncImpl (Sticky mref) lo loc src level msg = - case mref of - Nothing -> - loggerFunc - lo - out - loc - src - (case level of - LevelOther "sticky-done" -> LevelInfo - LevelOther "sticky" -> LevelInfo - _ -> level) - msg - Just ref -> modifyMVar_ ref $ \sticky -> do - let backSpaceChar = '\8' - repeating = S8.replicate (maybe 0 T.length sticky) - clear = S8.hPutStr out - (repeating backSpaceChar <> - repeating ' ' <> - repeating backSpaceChar) - - -- Convert some GHC-generated Unicode characters as necessary - let msgText - | logUseUnicode lo = msgTextRaw - | otherwise = T.map replaceUnicode msgTextRaw - - case level of - LevelOther "sticky-done" -> do - clear - T.hPutStrLn out msgText - hFlush out - return Nothing - LevelOther "sticky" -> do - clear - T.hPutStr out msgText - hFlush out - return (Just msgText) - _ - | level >= logMinLevel lo -> do - clear - loggerFunc lo out loc src level $ toLogStr msgText - case sticky of - Nothing -> - return Nothing - Just line -> do - T.hPutStr out line >> hFlush out - return sticky - | otherwise -> - return sticky - where - out = stderr - msgTextRaw = T.decodeUtf8With T.lenientDecode msgBytes - msgBytes = fromLogStr (toLogStr msg) - --- | Replace Unicode characters with non-Unicode equivalents -replaceUnicode :: Char -> Char -replaceUnicode '\x2018' = '`' -replaceUnicode '\x2019' = '\'' -replaceUnicode c = c - --- | Logging function takes the log level into account. -loggerFunc :: ToLogStr msg - => LogOptions -> Handle -> Loc -> Text -> LogLevel -> msg -> IO () -loggerFunc lo outputChannel loc _src level msg = - when (level >= logMinLevel lo) - (liftIO (do out <- getOutput - T.hPutStrLn outputChannel out)) - where - getOutput = do - timestamp <- getTimestamp - l <- getLevel - lc <- getLoc - return $ T.concat - [ T.pack timestamp - , T.pack l - , T.pack (ansi [Reset]) - , T.decodeUtf8 (fromLogStr (toLogStr msg)) - , T.pack lc - , T.pack (ansi [Reset]) - ] - where - ansi xs | logUseColor lo = setSGRCode xs - | otherwise = "" - getTimestamp - | logVerboseFormat lo && logUseTime lo = - do now <- getZonedTime - return $ - ansi [SetColor Foreground Vivid Black] - ++ formatTime' now ++ ": " - | otherwise = return "" - where - formatTime' = - take timestampLength . formatTime defaultTimeLocale "%F %T.%q" - getLevel - | logVerboseFormat lo = - return ((case level of - LevelDebug -> ansi [SetColor Foreground Dull Green] - LevelInfo -> ansi [SetColor Foreground Dull Blue] - LevelWarn -> ansi [SetColor Foreground Dull Yellow] - LevelError -> ansi [SetColor Foreground Dull Red] - LevelOther _ -> ansi [SetColor Foreground Dull Magenta]) ++ - "[" ++ - map toLower (drop 5 (show level)) ++ - "] ") - | otherwise = return "" - getLoc - | logVerboseFormat lo = - return $ - ansi [SetColor Foreground Vivid Black] ++ - "\n@(" ++ fileLocStr ++ ")" - | otherwise = return "" - fileLocStr = - fromMaybe file (stripPrefix dirRoot file) ++ - ':' : - line loc ++ - ':' : - char loc - where - file = loc_filename loc - line = show . fst . loc_start - char = show . snd . loc_start - dirRoot = $(lift . T.unpack . fromJust . T.stripSuffix (T.pack $ "Stack" "Types" "StackT.hs") . T.pack . loc_filename =<< location) - --- | 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 = - if terminal - then do state <- liftIO (newMVar Nothing) - originalMode <- liftIO (hGetBuffering stdout) - liftIO (hSetBuffering stdout NoBuffering) - a <- m (Sticky (Just state)) - state' <- liftIO (takeMVar state) - liftIO (when (isJust state') (S8.putStr "\n")) - liftIO (hSetBuffering stdout originalMode) - return a - else m (Sticky Nothing) - --- | Write a "sticky" line to the terminal. Any subsequent lines will --- overwrite this one, and that same line will be repeated below --- again. In other words, the line sticks at the bottom of the output --- forever. Running this function again will replace the sticky line --- with a new sticky line. When you want to get rid of the sticky --- line, run 'logStickyDone'. --- -logSticky :: Q Exp -logSticky = - logOther "sticky" - --- | This will print out the given message with a newline and disable --- any further stickiness of the line until a new call to 'logSticky' --- happens. --- --- It might be better at some point to have a 'runSticky' function --- that encompasses the logSticky->logStickyDone pairing. -logStickyDone :: Q Exp -logStickyDone = - logOther "sticky-done" diff --git a/src/Stack/Types/StringError.hs b/src/Stack/Types/StringError.hs deleted file mode 100644 --- a/src/Stack/Types/StringError.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE MagicHash #-} - -module Stack.Types.StringError where - -import Control.Exception -import Control.Monad.Catch -import Data.Typeable -import GHC.Prim - -newtype StringError = StringError String - deriving (Typeable) - -instance Exception StringError -instance Show StringError where show (StringError str) = str - -throwString :: MonadThrow m => String -> m a -throwString = throwM . StringError - -errorString :: String -> a -errorString = raise# . toException . StringError diff --git a/src/Stack/Types/TemplateName.hs b/src/Stack/Types/TemplateName.hs --- a/src/Stack/Types/TemplateName.hs +++ b/src/Stack/Types/TemplateName.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,13 +8,8 @@ module Stack.Types.TemplateName where -import Control.Error.Safe (justErr) -import Control.Applicative import Data.Aeson.Extended (FromJSON, withText, parseJSON) import Data.Aeson.Types (typeMismatch) -import Data.Foldable (asum) -import Data.Monoid -import Data.Text (Text) import qualified Data.Text as T import Data.Yaml (Value(Object), (.:?)) import Language.Haskell.TH @@ -21,8 +17,7 @@ import qualified Options.Applicative as O import Path import Path.Internal -import Prelude -import Stack.Types.StringError +import Stack.Prelude -- | A template name. data TemplateName = TemplateName !Text !TemplatePath @@ -80,7 +75,7 @@ Nothing -> parseValidFile (T.pack fname) (fname <> ".hsfiles") fname Just prefix -> parseValidFile prefix fname fname where - parseValidFile prefix hsf orig = justErr expected + parseValidFile prefix hsf orig = maybe (Left expected) Right $ asum (validParses prefix hsf orig) validParses prefix hsf orig = -- NOTE: order is important @@ -95,7 +90,7 @@ mkTemplateName :: String -> Q Exp mkTemplateName s = case parseTemplateNameFromString s of - Left{} -> errorString ("Invalid template name: " ++ show s) + Left{} -> runIO $ throwString ("Invalid template name: " ++ show s) Right (TemplateName (T.unpack -> prefix) p) -> [|TemplateName (T.pack prefix) $(pn)|] where pn = diff --git a/src/Stack/Types/Urls.hs b/src/Stack/Types/Urls.hs --- a/src/Stack/Types/Urls.hs +++ b/src/Stack/Types/Urls.hs @@ -1,16 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Stack.Types.Urls where -import Control.Applicative import Data.Aeson.Extended -import Data.Text (Text) -import Data.Monoid -import GHC.Generics (Generic) import Generics.Deriving.Monoid (memptydefault, mappenddefault) -import Prelude +import Stack.Prelude data Urls = Urls { urlsLatestSnapshot :: !Text diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} @@ -31,31 +32,19 @@ ,UpgradeTo(..)) where -import Control.Applicative -import Control.DeepSeq -import Control.Monad.Catch +import Stack.Prelude hiding (Vector) import Data.Aeson.Extended import Data.Attoparsec.Text -import Data.Data -import Data.Hashable +import Data.Hashable (Hashable (..)) import Data.List -import Data.Maybe (listToMaybe) -import Data.Monoid -import Data.Set (Set) import qualified Data.Set as Set -import Data.Store (Store) -import Data.Text (Text) import qualified Data.Text as T import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V -import Data.Word import Distribution.Text (disp) import qualified Distribution.Version as Cabal -import GHC.Generics import Language.Haskell.TH import Language.Haskell.TH.Syntax -import Prelude -- Fix warning: Word in Prelude from base-4.8. -import Stack.Types.StringError import Text.PrettyPrint (render) -- | A parse fail. @@ -150,19 +139,19 @@ -- | Convert to a Cabal version. toCabalVersion :: Version -> Cabal.Version toCabalVersion (Version v) = - Cabal.Version (map fromIntegral (V.toList v)) [] + Cabal.mkVersion (map fromIntegral (V.toList v)) -- | Convert from a Cabal version. fromCabalVersion :: Cabal.Version -> Version -fromCabalVersion (Cabal.Version vs _) = - let !v = V.fromList (map fromIntegral vs) +fromCabalVersion vs = + let !v = V.fromList (map fromIntegral (Cabal.versionNumbers vs)) in Version v -- | Make a package version. mkVersion :: String -> Q Exp mkVersion s = case parseVersionFromString s of - Nothing -> errorString ("Invalid package version: " ++ show s) + Nothing -> qRunIO $ throwString ("Invalid package version: " ++ show s) Just pn -> [|pn|] -- | Display a version range diff --git a/src/Stack/Types/VersionIntervals.hs b/src/Stack/Types/VersionIntervals.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/VersionIntervals.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Stack.Types.VersionIntervals + ( VersionIntervals + , toVersionRange + , fromVersionRange + , withinIntervals + , unionVersionIntervals + , intersectVersionIntervals + ) where + +import Stack.Types.Version +import qualified Distribution.Version as C +import Stack.Prelude + +newtype VersionIntervals = VersionIntervals [VersionInterval] + deriving (Generic, Show, Eq, Data, Typeable) +instance Store VersionIntervals +instance NFData VersionIntervals + +data VersionInterval = VersionInterval + { viLowerVersion :: !Version + , viLowerBound :: !Bound + , viUpper :: !(Maybe (Version, Bound)) + } + deriving (Generic, Show, Eq, Data, Typeable) +instance Store VersionInterval +instance NFData VersionInterval + +data Bound = ExclusiveBound | InclusiveBound + deriving (Generic, Show, Eq, Data, Typeable) +instance Store Bound +instance NFData Bound + +toVersionRange :: VersionIntervals -> C.VersionRange +toVersionRange = C.fromVersionIntervals . toCabal + +fromVersionRange :: C.VersionRange -> VersionIntervals +fromVersionRange = fromCabal . C.toVersionIntervals + +withinIntervals :: Version -> VersionIntervals -> Bool +withinIntervals v vi = C.withinIntervals (toCabalVersion v) (toCabal vi) + +unionVersionIntervals :: VersionIntervals -> VersionIntervals -> VersionIntervals +unionVersionIntervals x y = fromCabal $ C.unionVersionIntervals + (toCabal x) + (toCabal y) + +intersectVersionIntervals :: VersionIntervals -> VersionIntervals -> VersionIntervals +intersectVersionIntervals x y = fromCabal $ C.intersectVersionIntervals + (toCabal x) + (toCabal y) + +toCabal :: VersionIntervals -> C.VersionIntervals +toCabal (VersionIntervals vi) = fromMaybe + (error "Stack.Types.VersionIntervals.toCabal: invariant violated") + (C.mkVersionIntervals $ map go vi) + where + go (VersionInterval lowerV lowerB mupper) = + ( C.LowerBound (toCabalVersion lowerV) (toCabalBound lowerB) + , case mupper of + Nothing -> C.NoUpperBound + Just (v, b) -> C.UpperBound (toCabalVersion v) (toCabalBound b) + ) + +fromCabal :: C.VersionIntervals -> VersionIntervals +fromCabal = + VersionIntervals . map go . C.versionIntervals + where + go (C.LowerBound lowerV lowerB, upper) = VersionInterval + { viLowerVersion = fromCabalVersion lowerV + , viLowerBound = fromCabalBound lowerB + , viUpper = + case upper of + C.NoUpperBound -> Nothing + C.UpperBound v b -> Just (fromCabalVersion v, fromCabalBound b) + } + +toCabalBound :: Bound -> C.Bound +toCabalBound ExclusiveBound = C.ExclusiveBound +toCabalBound InclusiveBound = C.InclusiveBound + +fromCabalBound :: C.Bound -> Bound +fromCabalBound C.ExclusiveBound = ExclusiveBound +fromCabalBound C.InclusiveBound = InclusiveBound diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -11,32 +12,28 @@ , upgradeOpts ) where -import Control.Exception.Safe (catchAny) -import Control.Monad (unless, when) -import Control.Monad.IO.Class -import Control.Monad.Logger -import Data.Foldable (forM_) +import Stack.Prelude hiding (force) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List import qualified Data.Map as Map -import Data.Maybe (isNothing) -import Data.Monoid.Extra import qualified Data.Text as T +import Distribution.Version (mkVersion') import Lens.Micro (set) import Options.Applicative import Path -import Path.IO import qualified Paths_stack as Paths import Stack.Build import Stack.Config import Stack.Fetch import Stack.PackageIndex +import Stack.PrettyPrint import Stack.Setup import Stack.Types.PackageIdentifier +import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.Version import Stack.Types.Config import Stack.Types.Resolver -import Stack.Types.StackT -import Stack.Types.StringError import System.Exit (ExitCode (ExitSuccess)) import System.Process (rawSystem, readProcess) import System.Process.Run @@ -56,10 +53,10 @@ <> showDefault)) <*> switch (long "force-download" <> - help "Download a stack executable, even if the version number is older than what we have") + help "Download the latest available stack executable") <*> optional (strOption (long "binary-version" <> - help "Download a specific version, even if it's out of date")) + help "Download a specific stack version")) <*> optional (strOption (long "github-org" <> help "Github organization name")) @@ -68,7 +65,7 @@ help "Github repository name")) sourceOpts = SourceOpts - <$> ((\fromGit repo -> if fromGit then Just repo else Nothing) + <$> ((\fromGit repo branch -> if fromGit then Just (repo, branch) else Nothing) <$> switch ( long "git" <> help "Clone from Git instead of downloading from Hackage (more dangerous)" ) @@ -76,7 +73,12 @@ ( long "git-repo" <> help "Clone from specified git repository" <> value "https://github.com/commercialhaskell/stack" - <> showDefault )) + <> showDefault ) + <*> strOption + ( long "git-branch" + <> help "Clone from this git branch" + <> value "master" + <> showDefault )) data BinaryOpts = BinaryOpts { _boPlatform :: !(Maybe String) @@ -89,9 +91,7 @@ , _boGithubRepo :: !(Maybe String) } deriving Show -newtype SourceOpts = SourceOpts - { _soRepo :: Maybe String - } +newtype SourceOpts = SourceOpts (Maybe (String, String)) -- repo and branch deriving Show data UpgradeOpts = UpgradeOpts @@ -100,12 +100,12 @@ } deriving Show -upgrade :: (StackM env m, HasConfig env) +upgrade :: HasConfig env => ConfigMonoid -> Maybe AbstractResolver -> Maybe String -- ^ git hash at time of building, if known -> UpgradeOpts - -> m () + -> RIO env () upgrade gConfigMonoid mresolver builtHash (UpgradeOpts mbo mso) = case (mbo, mso) of -- FIXME It would be far nicer to capture this case in the @@ -117,19 +117,18 @@ -- See #2977 - if --git or --git-repo is specified, do source upgrade. (_, Just so@(SourceOpts (Just _))) -> source so (Just bo, Just so) -> binary bo `catchAny` \e -> do - $logWarn "Exception occured when trying to perform binary upgrade:" - $logWarn $ T.pack $ show e - $logWarn "Falling back to source upgrade" + prettyWarnL + [ flow "Exception occured when trying to perform binary upgrade:" + , fromString . show $ e + , line <> flow "Falling back to source upgrade" + ] source so where binary bo = binaryUpgrade bo source so = sourceUpgrade gConfigMonoid mresolver builtHash so -binaryUpgrade - :: (StackM env m, HasConfig env) - => BinaryOpts - -> m () +binaryUpgrade :: HasConfig env => BinaryOpts -> RIO env () binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) = do platforms0 <- case mplatform of @@ -145,32 +144,34 @@ isNewer <- case mdownloadVersion of Nothing -> do - $logError "Unable to determine upstream version from Github metadata" - unless force $ - $logError "Rerun with --force-download to force an upgrade" + prettyErrorL $ + flow "Unable to determine upstream version from Github metadata" + : + [ line <> flow "Rerun with --force-download to force an upgrade" + | not force] return False Just downloadVersion -> do - $logInfo $ T.concat - [ "Current Stack version: " - , versionText stackVersion - , ", available download version: " - , versionText downloadVersion + prettyInfoL + [ flow "Current Stack version:" + , display stackVersion <> "," + , flow "available download version:" + , display downloadVersion ] return $ downloadVersion > stackVersion toUpgrade <- case (force, isNewer) of (False, False) -> do - $logInfo "Skipping binary upgrade, you are already running the most recent version" + prettyInfoS "Skipping binary upgrade, you are already running the most recent version" return False (True, False) -> do - $logInfo "Forcing binary upgrade" + prettyInfoS "Forcing binary upgrade" return True (_, True) -> do - $logInfo "Newer version detected, downloading" + prettyInfoS "Newer version detected, downloading" return True when toUpgrade $ do config <- view configL - downloadStackExe platforms0 archiveInfo (configLocalBin config) $ \tmpFile -> do + downloadStackExe platforms0 archiveInfo (configLocalBin config) True $ \tmpFile -> do -- Sanity check! ec <- rawSystem (toFilePath tmpFile) ["--version"] @@ -178,60 +179,61 @@ $ throwString "Non-success exit code from running newly downloaded executable" sourceUpgrade - :: (StackM env m, HasConfig env) + :: HasConfig env => ConfigMonoid -> Maybe AbstractResolver -> Maybe String -> SourceOpts - -> m () + -> RIO env () sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = withSystemTempDir "stack-upgrade" $ \tmp -> do menv <- getMinimalEnvOverride mdir <- case gitRepo of - Just repo -> do - remote <- liftIO $ readProcess "git" ["ls-remote", repo, "master"] [] - let latestCommit = head . words $ remote + Just (repo, branch) -> do + remote <- liftIO $ readProcess "git" ["ls-remote", repo, branch] [] + latestCommit <- + case words remote of + [] -> throwString $ "No commits found for branch " ++ branch ++ " on repo " ++ repo + x:_ -> return x when (isNothing builtHash) $ - $logWarn $ "Information about the commit this version of stack was " + prettyWarnS $ + "Information about the commit this version of stack was " <> "built from is not available due to how it was built. " <> "Will continue by assuming an upgrade is needed " <> "because we have no information to the contrary." if builtHash == Just latestCommit then do - $logInfo "Already up-to-date, no upgrade required" + prettyInfoS "Already up-to-date, no upgrade required" return Nothing else do - $logInfo "Cloning stack" + prettyInfoS "Cloning stack" -- NOTE: "--recursive" was added after v1.0.0 (and before the -- next release). This means that we can't use submodules in -- the stack repo until we're comfortable with "stack upgrade -- --git" not working for earlier versions. - let args = [ "clone", repo , "stack", "--depth", "1", "--recursive"] + let args = [ "clone", repo , "stack", "--depth", "1", "--recursive", "--branch", branch] runCmd (Cmd (Just tmp) "git" menv args) Nothing return $ Just $ tmp $(mkRelDir "stack") Nothing -> do updateAllIndices - (caches, _gitShaCaches) <- getPackageCaches - let latest = Map.fromListWith max - $ map toTuple - $ Map.keys + PackageCache caches <- getPackageCaches + let versions + = filter (/= $(mkVersion "9.9.9")) -- Mistaken upload to Hackage, just ignore it + $ maybe [] HashMap.keys + $ HashMap.lookup $(mkPackageName "stack") caches - -- Mistaken upload to Hackage, just ignore it - $ Map.delete (PackageIdentifier - $(mkPackageName "stack") - $(mkVersion "9.9.9")) + when (null versions) (throwString "No stack found in package indices") - caches - case Map.lookup $(mkPackageName "stack") latest of - Nothing -> throwString "No stack found in package indices" - Just version | version <= fromCabalVersion Paths.version -> do - $logInfo "Already at latest version, no upgrade required" + let version = Data.List.maximum versions + if version <= fromCabalVersion (mkVersion' Paths.version) + then do + prettyInfoS "Already at latest version, no upgrade required" return Nothing - Just version -> do + else do let ident = PackageIdentifier $(mkPackageName "stack") version paths <- unpackPackageIdents tmp Nothing - -- accept latest cabal revision by not supplying a Git SHA - $ Map.singleton ident Nothing + -- accept latest cabal revision + [PackageIdentifierRevision ident CFILatest] case Map.lookup ident paths of Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found" Just path -> return $ Just path @@ -241,11 +243,11 @@ gConfigMonoid mresolver (SYLOverride $ dir $(mkRelFile "stack.yaml")) - bconfig <- lcLoadBuildConfig lc Nothing - envConfig1 <- runInnerStackT bconfig $ setupEnv $ Just $ + bconfig <- liftIO $ lcLoadBuildConfig lc Nothing + envConfig1 <- runRIO bconfig $ setupEnv $ Just $ "Try rerunning with --install-ghc to install the correct GHC into " <> T.pack (toFilePath (configLocalPrograms (view configL bconfig))) - runInnerStackT (set (buildOptsL.buildOptsInstallExesL) True envConfig1) $ + runRIO (set (buildOptsL.buildOptsInstallExesL) True envConfig1) $ build (const $ return ()) Nothing defaultBuildOptsCLI { boptsCLITargets = ["stack"] } diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -13,10 +14,7 @@ , loadCreds ) where -import Control.Applicative -import Control.Exception.Safe (handleIO, tryIO) -import qualified Control.Exception as E -import Control.Monad (void, when, unless) +import Stack.Prelude import Data.Aeson (FromJSON (..), ToJSON (..), decode', encode, @@ -24,9 +22,7 @@ (.:), (.=)) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy as L -import Data.Conduit (ConduitM, runConduit, (.|)) import qualified Data.Conduit.Binary as CB -import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as TIO @@ -44,17 +40,14 @@ import Network.HTTP.Client.TLS (getGlobalManager, applyDigestAuth, displayDigestAuthException) -import Path (toFilePath) -import Prelude -- Fix redundant import warnings import Stack.Types.Config import Stack.Types.PackageIdentifier (PackageIdentifier, packageIdentifierString, packageIdentifierName) import Stack.Types.PackageName (packageNameString) -import Stack.Types.StringError import System.Directory (createDirectoryIfMissing, removeFile) import System.FilePath ((), takeFileName) -import System.IO (hFlush, stdout) +import System.IO (hFlush, stdout, putStrLn, putStr, getLine, print) -- TODO remove putStrLn, use logInfo import System.IO.Echo (withoutInputEcho) -- | Username and password to log into Hackage. @@ -95,9 +88,6 @@ return $ mkCreds fp where fromPrompt fp = do - when (configSaveHackageCreds config) $ do - putStrLn "NOTE: Username and password will be saved in a local file" - putStrLn "You can modify this behavior with the save-hackage-creds config option" putStr "Hackage username: " hFlush stdout username <- TIO.getLine @@ -107,9 +97,32 @@ , hcPassword = password , hcCredsFile = fp } - L.writeFile fp (encode hc) + + when (configSaveHackageCreds config) $ do + let prompt = "Save hackage credentials to file at " ++ fp ++ " [y/n]? " + putStr prompt + input <- loopPrompt prompt + putStrLn "NOTE: Avoid this prompt in the future by using: save-hackage-creds: false" + hFlush stdout + case input of + "y" -> do + L.writeFile fp (encode hc) + putStrLn "Saved!" + hFlush stdout + _ -> return () + return hc + loopPrompt :: String -> IO String + loopPrompt p = do + input <- TIO.getLine + case input of + "y" -> return "y" + "n" -> return "n" + _ -> do + putStr p + loopPrompt p + credsFile :: Config -> IO FilePath credsFile config = do let dir = toFilePath (configStackRoot config) "upload" @@ -137,7 +150,7 @@ case ereq of Left e -> do putStrLn "WARNING: No HTTP digest prompt found, this will probably fail" - case E.fromException e of + case fromException e of Just e' -> putStrLn $ displayDigestAuthException e' Nothing -> print e return req0 diff --git a/src/System/Process/Log.hs b/src/System/Process/Log.hs --- a/src/System/Process/Log.hs +++ b/src/System/Process/Log.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | Separate module because TH. @@ -9,55 +9,45 @@ ,showProcessArgDebug) where -import Control.Monad.IO.Class -import Control.Monad.Logger -import Data.Monoid -import Data.Text (Text) import qualified Data.Text as T -import Language.Haskell.TH +import Stack.Prelude import qualified System.Clock as Clock import System.Process (CreateProcess(..), CmdSpec(..)) -- | Log running a process with its arguments, for debugging (-v). -logCreateProcess :: Q Exp -logCreateProcess = - [|let f :: MonadLogger m => CreateProcess -> m () - f CreateProcess { cmdspec = ShellCommand shellCmd } = - $logDebug ("Creating shell process: " <> T.pack shellCmd) - f CreateProcess { cmdspec = RawCommand name args } = - $logDebug - ("Creating process: " <> T.pack name <> " " <> - T.intercalate - " " - (map showProcessArgDebug args)) - in f|] +logCreateProcess :: MonadLogger m => CreateProcess -> m () +logCreateProcess CreateProcess { cmdspec = ShellCommand shellCmd } = + logDebug ("Creating shell process: " <> T.pack shellCmd) +logCreateProcess CreateProcess { cmdspec = RawCommand name args } = + logDebug + ("Creating process: " <> T.pack name <> " " <> + T.intercalate + " " + (map showProcessArgDebug args)) -- | Log running a process with its arguments, for debugging (-v). -- -- This logs one message before running the process and one message after. -withProcessTimeLog :: Q Exp -withProcessTimeLog = - [|let f :: (MonadIO m, MonadLogger m) => String -> [String] -> m a -> m a - f name args proc = do - let cmdText = - T.intercalate - " " - (T.pack name : map showProcessArgDebug args) - $logDebug ("Run process: " <> cmdText) - start <- liftIO $ Clock.getTime Clock.Monotonic - x <- proc - end <- liftIO $ Clock.getTime Clock.Monotonic - let diff = Clock.diffTimeSpec start end - -- useAnsi <- asks getAnsiTerminal - let useAnsi = True - $logDebug - ("Process finished in " <> - (if useAnsi then "\ESC[92m" else "") <> -- green - timeSpecMilliSecondText diff <> - (if useAnsi then "\ESC[0m" else "") <> -- reset - ": " <> cmdText) - return x - in f|] +withProcessTimeLog :: (MonadIO m, MonadLogger m) => String -> [String] -> m a -> m a +withProcessTimeLog name args proc = do + let cmdText = + T.intercalate + " " + (T.pack name : map showProcessArgDebug args) + logDebug ("Run process: " <> cmdText) + start <- liftIO $ Clock.getTime Clock.Monotonic + x <- proc + end <- liftIO $ Clock.getTime Clock.Monotonic + let diff = Clock.diffTimeSpec start end + -- useAnsi <- asks getAnsiTerminal + let useAnsi = True + logDebug + ("Process finished in " <> + (if useAnsi then "\ESC[92m" else "") <> -- green + timeSpecMilliSecondText diff <> + (if useAnsi then "\ESC[0m" else "") <> -- reset + ": " <> cmdText) + return x timeSpecMilliSecondText :: Clock.TimeSpec -> Text timeSpecMilliSecondText t = @@ -67,7 +57,7 @@ -- debugging purposes, not functionally important. showProcessArgDebug :: String -> Text showProcessArgDebug x - | any special x = T.pack (show x) + | any special x || null x = T.pack (show x) | otherwise = T.pack x where special '"' = True special ' ' = True diff --git a/src/System/Process/PagerEditor.hs b/src/System/Process/PagerEditor.hs --- a/src/System/Process/PagerEditor.hs +++ b/src/System/Process/PagerEditor.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables, RankNTypes, DeriveDataTypeable #-} -- | Run external pagers (@$PAGER@, @less@, @more@) and editors (@$VISUAL@, @@ -18,18 +19,16 @@ ,EditorException(..)) where -import Control.Exception (try,IOException,throwIO,Exception) +import Stack.Prelude hiding (ByteString) import Data.ByteString.Lazy (ByteString,hPut,readFile) import Data.ByteString.Builder (Builder,stringUtf8,hPutBuilder) -import Data.Typeable (Typeable) import System.Directory (findExecutable) import System.Environment (lookupEnv) import System.Exit (ExitCode(..)) import System.FilePath (()) import System.Process (createProcess,shell,proc,waitForProcess,StdStream (CreatePipe) ,CreateProcess(std_in, close_fds, delegate_ctlc)) -import System.IO (hClose,Handle,hPutStr,readFile,withFile,IOMode(WriteMode),stdout) -import System.IO.Temp (withSystemTempDirectory) +import System.IO (hClose,hPutStr,readFile,stdout) -- | Run pager, providing a function that writes to the pager's input. pageWriter :: (Handle -> IO ()) -> IO () diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -1,10 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} -- | Reading from external processes. @@ -37,15 +35,7 @@ ) where -import Control.Applicative -import Control.Arrow ((***), first) -import Control.Concurrent.Async (concurrently) -import Control.Exception hiding (try, catch) -import Control.Monad (join, liftM, unless, void) -import Control.Monad.Catch (MonadThrow, MonadCatch, throwM, try, catch) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger -import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith) +import Stack.Prelude import qualified Data.ByteString as S import Data.ByteString.Builder import qualified Data.ByteString.Lazy as L @@ -53,30 +43,22 @@ import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.Process hiding (callProcess) -import Data.IORef -import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (isJust, maybeToList, fromMaybe) -import Data.Monoid -import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT -import Data.Typeable (Typeable) import Distribution.System (OS (Windows), Platform (Platform)) -import Language.Haskell.TH as TH (location) import Path import Path.Extra import Path.IO hiding (findExecutable) -import Prelude -- Fix AMP warning import qualified System.Directory as D import System.Environment (getEnvironment) import System.Exit import qualified System.FilePath as FP -import System.IO (Handle, hClose) +import System.IO (hClose) import System.Process.Log -import Prelude () -- Hide post-AMP warnings -- | Override the environment received by a child process. data EnvOverride = EnvOverride @@ -148,7 +130,7 @@ -- | Read from the process, ignoring any output. -- -- Throws a 'ReadProcessException' exception if the process fails. -readProcessNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +readProcessNull :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional working directory -> EnvOverride -> String -- ^ Command @@ -159,7 +141,7 @@ -- | Try to produce a strict 'S.ByteString' from the stdout of a -- process. -tryProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +tryProcessStdout :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride -> String -- ^ Command @@ -170,7 +152,7 @@ -- | Try to produce strict 'S.ByteString's from the stderr and stdout of a -- process. -tryProcessStderrStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +tryProcessStderrStdout :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride -> String -- ^ Command @@ -182,7 +164,7 @@ -- | Produce a strict 'S.ByteString' from the stdout of a process. -- -- Throws a 'ReadProcessException' exception if the process fails. -readProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +readProcessStdout :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride -> String -- ^ Command @@ -195,7 +177,7 @@ -- | Produce strict 'S.ByteString's from the stderr and stdout of a process. -- -- Throws a 'ReadProcessException' exception if the process fails. -readProcessStderrStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) +readProcessStderrStdout :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride -> String -- ^ Command @@ -249,7 +231,7 @@ -- -- Throws a 'ReadProcessException' if unsuccessful. sinkProcessStdout - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride -> String -- ^ Command @@ -272,7 +254,7 @@ (\(ProcessExitedUnsuccessfully cp ec) -> do stderrBuilder <- liftIO (readIORef stderrBuffer) stdoutBuilder <- liftIO (readIORef stdoutBuffer) - throwM $ ProcessFailed + liftIO $ throwM $ ProcessFailed cp ec (toLazyByteString stdoutBuilder) @@ -280,15 +262,16 @@ return sinkRet logProcessStderrStdout - :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) + :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -> String -> EnvOverride -> [String] -> m () -logProcessStderrStdout mdir name menv args = liftBaseWith $ \restore -> do - let logLines = CB.lines =$ CL.mapM_ (void . restore . monadLoggerLog $(TH.location >>= liftLoc) "" LevelInfo . toLogStr) - void $ restore $ sinkProcessStderrStdout mdir menv name args logLines logLines +logProcessStderrStdout mdir name menv args = withUnliftIO $ \u -> do + let logLines = CB.lines =$ CL.mapM_ (unliftIO u . logInfo . decodeUtf8With lenientDecode) + ((), ()) <- unliftIO u $ sinkProcessStderrStdout mdir menv name args logLines logLines + return () -- | Consume the stdout and stderr of a process feeding strict 'S.ByteString's to the consumers. -- @@ -303,7 +286,7 @@ -> m (e,o) sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout = do name' <- preProcess wd menv name - $withProcessTimeLog name' args $ + withProcessTimeLog name' args $ liftIO $ withCheckedProcess (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd } (\ClosedStream out err -> f err out) @@ -337,7 +320,7 @@ -> m () sinkProcessStderrStdoutHandle wd menv name args err out = do name' <- preProcess wd menv name - $withProcessTimeLog name' args $ + withProcessTimeLog name' args $ liftIO $ withCheckedProcess (proc name' args) { env = envHelper menv diff --git a/src/System/Process/Run.hs b/src/System/Process/Run.hs --- a/src/System/Process/Run.hs +++ b/src/System/Process/Run.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} @@ -21,17 +19,9 @@ ) where -import Control.Exception.Lifted -import Control.Monad (liftM) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger (MonadLogger, logError) -import Control.Monad.Trans.Control (MonadBaseControl) +import Stack.Prelude import Data.Conduit.Process hiding (callProcess) -import Data.Foldable (forM_) -import Data.Text (Text) import qualified Data.Text as T -import Path (Dir, Abs, Path, toFilePath) -import Prelude -- Fix AMP warning import System.Exit (exitWith, ExitCode (..)) import System.IO import qualified System.Process @@ -51,14 +41,14 @@ -- If it exits with anything but success, prints an error -- and then calls 'exitWith' to exit the program. runCmd :: forall (m :: * -> *). - (MonadLogger m,MonadIO m,MonadBaseControl IO m) + (MonadLogger m, MonadUnliftIO m) => Cmd -> Maybe Text -- ^ optional additional error message -> m () runCmd = runCmd' id runCmd' :: forall (m :: * -> *). - (MonadLogger m,MonadIO m,MonadBaseControl IO m) + (MonadLogger m, MonadUnliftIO m) => (CreateProcess -> CreateProcess) -> Cmd -> Maybe Text -- ^ optional additional error message @@ -67,7 +57,7 @@ result <- try (callProcess' modCP cmd) case result of Left (ProcessExitedUnsuccessfully _ ec) -> do - $logError $ + logError $ T.pack $ concat $ [ "Exit code " @@ -78,7 +68,7 @@ Nothing -> [] Just mbDir -> [" in ", toFilePath mbDir] ) - forM_ mbErrMsg $logError + forM_ mbErrMsg logError liftIO (exitWith ec) Right () -> return () @@ -99,13 +89,13 @@ => (CreateProcess -> CreateProcess) -> Cmd -> m () callProcess' modCP cmd = do c <- liftM modCP (cmdToCreateProcess cmd) - $logCreateProcess c + logCreateProcess c liftIO $ do (_, _, _, p) <- System.Process.createProcess c exit_code <- waitForProcess p case exit_code of ExitSuccess -> return () - ExitFailure _ -> throwIO (ProcessExitedUnsuccessfully c exit_code) + ExitFailure _ -> throwM (ProcessExitedUnsuccessfully c exit_code) callProcessInheritStderrStdout :: (MonadIO m, MonadLogger m) => Cmd -> m () callProcessInheritStderrStdout cmd = do @@ -115,14 +105,14 @@ callProcessObserveStdout :: (MonadIO m, MonadLogger m) => Cmd -> m String callProcessObserveStdout cmd = do c <- liftM modCP (cmdToCreateProcess cmd) - $logCreateProcess c + logCreateProcess c liftIO $ do (_, Just hStdout, _, p) <- System.Process.createProcess c hSetBuffering hStdout NoBuffering exit_code <- waitForProcess p case exit_code of ExitSuccess -> hGetLine hStdout - ExitFailure _ -> throwIO (ProcessExitedUnsuccessfully c exit_code) + ExitFailure _ -> throwM (ProcessExitedUnsuccessfully c exit_code) where modCP c = c { std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit } @@ -136,7 +126,7 @@ -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess' tag modCP cmd = do c <- liftM modCP (cmdToCreateProcess cmd) - $logCreateProcess c + logCreateProcess c liftIO $ System.Process.createProcess_ tag c -- Throws a 'ReadProcessException' if process is not found. diff --git a/src/Text/PrettyPrint/Leijen/Extended.hs b/src/Text/PrettyPrint/Leijen/Extended.hs --- a/src/Text/PrettyPrint/Leijen/Extended.hs +++ b/src/Text/PrettyPrint/Leijen/Extended.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} @@ -117,18 +118,14 @@ -- @ ) where -import Control.Monad.Reader -import Data.Either (partitionEithers) +import Control.Monad.Reader (runReader, local) import qualified Data.Map.Strict as M -import Data.Maybe (mapMaybe) -import Data.Monoid -import Data.String import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as LTB +import Stack.Prelude import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), ConsoleIntensity(..), SGR(..), setSGRCode, hSupportsANSI) -import System.IO (Handle) import qualified Text.PrettyPrint.Annotated.Leijen as P import Text.PrettyPrint.Annotated.Leijen hiding ((<>), display) @@ -165,7 +162,7 @@ type AnsiDoc = Doc AnsiAnn newtype AnsiAnn = AnsiAnn [SGR] - deriving (Eq, Ord, Show, Monoid) + deriving (Eq, Show, Monoid) class HasAnsiAnn a where getAnsiAnn :: a -> AnsiAnn @@ -179,24 +176,24 @@ instance HasAnsiAnn () where getAnsiAnn _ = mempty -displayPlain :: Display a => a -> T.Text -displayPlain = LT.toStrict . displayAnsiSimple . renderDefault . fmap (const mempty) . display +displayPlain :: Display a => Int -> a -> T.Text +displayPlain w = LT.toStrict . displayAnsiSimple . renderDefault w . fmap (const mempty) . display -- TODO: tweak these settings more? -- TODO: options for settings if this is released as a lib -renderDefault :: Doc a -> SimpleDoc a -renderDefault = renderPretty 1 120 +renderDefault :: Int -> Doc a -> SimpleDoc a +renderDefault = renderPretty 1 -displayAnsi :: (Display a, HasAnsiAnn (Ann a)) => a -> T.Text -displayAnsi = LT.toStrict . displayAnsiSimple . renderDefault . toAnsiDoc . display +displayAnsi :: (Display a, HasAnsiAnn (Ann a)) => Int -> a -> T.Text +displayAnsi w = LT.toStrict . displayAnsiSimple . renderDefault w . toAnsiDoc . display hDisplayAnsi :: (Display a, HasAnsiAnn (Ann a), MonadIO m) - => Handle -> a -> m () -hDisplayAnsi h x = liftIO $ do + => Handle -> Int -> a -> m () +hDisplayAnsi h w x = liftIO $ do useAnsi <- hSupportsANSI h - T.hPutStr h $ if useAnsi then displayAnsi x else displayPlain x + T.hPutStr h $ if useAnsi then displayAnsi w x else displayPlain w x displayAnsiSimple :: SimpleDoc AnsiAnn -> LT.Text displayAnsiSimple doc = @@ -207,7 +204,7 @@ let sgrs' = mapMaybe (\sgr -> if sgr == Reset then Nothing else Just (getSGRTag sgr, sgr)) sgrs new = if Reset `elem` sgrs then M.fromList sgrs' - else foldl (\mp (tag, sgr) -> M.insert tag sgr mp) old sgrs' + else foldl' (\mp (tag, sgr) -> M.insert tag sgr mp) old sgrs' (extra, contents) <- local (const new) inner return (extra, transitionCodes old new <> contents <> transitionCodes new old) transitionCodes old new = @@ -300,6 +297,7 @@ | TagSwapForegroundBackground | TagColorForeground | TagColorBackground + | TagRGBColor deriving (Eq, Ord) getSGRTag :: SGR -> SGRTag @@ -312,3 +310,4 @@ getSGRTag SetSwapForegroundBackground{} = TagSwapForegroundBackground getSGRTag (SetColor Foreground _ _) = TagColorForeground getSGRTag (SetColor Background _ _) = TagColorBackground +getSGRTag SetRGBColor{} = TagRGBColor diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -1,13 +1,16 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} +#ifdef USE_GIT_INFO +{-# LANGUAGE TemplateHaskell #-} +#endif + -- | Main stack tool entry point. module Main (main) where @@ -15,32 +18,25 @@ #ifndef HIDE_DEP_VERSIONS import qualified Build_stack #endif -import Control.Exception -import Control.Monad hiding (mapM, forM) -import Control.Monad.IO.Class -import Control.Monad.Logger +import Stack.Prelude import Control.Monad.Reader (local) -import Control.Monad.Trans.Either (EitherT) +import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Writer.Lazy (Writer) import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping)) import Data.Attoparsec.Interpreter (getInterpreterArgs) import qualified Data.ByteString.Lazy as L import Data.IORef.RunOnce (runOnce) import Data.List -import qualified Data.Map as Map -import Data.Maybe -import Data.Monoid -import Data.Text (Text) +import qualified Data.Map.Strict as Map import qualified Data.Text as T -import Data.Traversable -import Data.Typeable (Typeable) import Data.Version (showVersion) import System.Process.Read #ifdef USE_GIT_INFO import Development.GitRev (gitCommitCount, gitHash) #endif import Distribution.System (buildArch, buildPlatform) -import Distribution.Text (display) +import qualified Distribution.Text as Cabal (display) +import Distribution.Version (mkVersion') import GHC.IO.Encoding (mkTextEncoding, textEncodingName) import Lens.Micro import Options.Applicative @@ -54,13 +50,12 @@ import Path import Path.IO import qualified Paths_stack as Meta -import Prelude hiding (pi, mapM) import Stack.Build -import Stack.BuildPlan -import Stack.Clean (CleanOpts, clean) +import Stack.Clean (CleanOpts(..), clean) import Stack.Config import Stack.ConfigCmd as ConfigCmd import Stack.Constants +import Stack.Constants.Config import Stack.Coverage import qualified Stack.Docker as Docker import Stack.Dot @@ -92,26 +87,25 @@ import Stack.Options.Utils import qualified Stack.PackageIndex import qualified Stack.Path +import Stack.PrettyPrint import Stack.Runners import Stack.Script import Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball', SDistOpts(..)) import Stack.SetupCmd import qualified Stack.Sig as Sig +import Stack.Snapshot (loadResolver) import Stack.Solver (solveExtraDeps) import Stack.Types.Version import Stack.Types.Config import Stack.Types.Compiler -import Stack.Types.Resolver import Stack.Types.Nix -import Stack.Types.StackT -import Stack.Types.StringError import Stack.Upgrade import qualified Stack.Upload as Upload import qualified System.Directory as D import System.Environment (getProgName, getArgs, withArgs) import System.Exit -import System.FilePath (pathSeparator) -import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..), hPutStrLn, Handle, hGetEncoding, hSetEncoding) +import System.FilePath (isValid, pathSeparator) +import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..), hPutStrLn, hGetEncoding, hSetEncoding) -- | Change the character encoding of the given Handle to transliterate -- on unsupported characters instead of throwing an exception @@ -133,16 +127,17 @@ -- See https://github.com/commercialhaskell/stack/issues/792 , [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) && commitCount /= ("UNKNOWN" :: String)] - , [" ", display buildArch] - , [depsString] + , [" ", Cabal.display buildArch] + , [depsString, warningString] ] where commitCount = $gitCommitCount #else versionString' = showVersion Meta.version - ++ ' ' : display buildArch + ++ ' ' : Cabal.display buildArch ++ depsString + ++ warningString where #endif #ifdef HIDE_DEP_VERSIONS @@ -150,6 +145,17 @@ #else depsString = "\nCompiled with:\n" ++ unlines (map ("- " ++) Build_stack.deps) #endif +#ifdef SUPPORTED_BUILD + warningString = "" +#else + warningString = unlines + [ "" + , "Warning: this is an unsupported build that may have been built with different" + , "versions of dependencies and GHC than the officially release binaries, and" + , "therefore may not behave identically. If you encounter problems, please try" + , "the latest official build by running 'stack upgrade --force-download'." + ] +#endif main :: IO () main = do @@ -183,7 +189,7 @@ case globalReExecVersion global of Just expectVersion -> do expectVersion' <- parseVersionFromString expectVersion - unless (checkVersion MatchMinor expectVersion' (fromCabalVersion Meta.version)) + unless (checkVersion MatchMinor expectVersion' (fromCabalVersion (mkVersion' Meta.version))) $ throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version) _ -> return () run global `catch` \e -> @@ -198,8 +204,7 @@ -- Vertically combine only the error component of the first argument with the -- error component of the second. vcatErrorHelp :: ParserHelp -> ParserHelp -> ParserHelp -vcatErrorHelp (ParserHelp e1 _ _ _ _) (ParserHelp e2 h2 u2 b2 f2) = - ParserHelp (vcatChunks [e2, e1]) h2 u2 b2 f2 +vcatErrorHelp h1 h2 = h2 { helpError = vcatChunks [helpError h2, helpError h1] } commandLineHandler :: FilePath @@ -262,11 +267,20 @@ buildCmd (buildOptsParser Haddock) addCommand' "new" - "Create a new project from a template. Run `stack templates' to see available templates." + (unwords [ "Create a new project from a template." + , "Run `stack templates' to see available templates." + , "Note: you can also specify a local file or a" + , "remote URL as a template." + ] ) newCmd newOptsParser addCommand' "templates" - "List the templates available for `stack new'." + (unwords [ "List the templates available for `stack new'." + , "Templates are drawn from" + , "https://github.com/commercialhaskell/stack-templates" + , "Note: `stack new' can also accept a template from a" + , "local file or a remote URL." + ] ) templatesCmd (pure ()) addCommand' "init" @@ -472,7 +486,7 @@ globalFooter = "Run 'stack --help' for global options that apply to all subcommands." type AddCommand = - EitherT (GlobalOpts -> IO ()) (Writer (Mod CommandFields (GlobalOpts -> IO (), GlobalOptsMonoid))) () + ExceptT (GlobalOpts -> IO ()) (Writer (Mod CommandFields (GlobalOpts -> IO (), GlobalOptsMonoid))) () -- | fall-through to external executables in `git` style if they exist -- (i.e. `stack something` looks for `stack-something` before @@ -493,7 +507,7 @@ -- TODO show the command in verbose mode -- hPutStrLn stderr $ unwords $ -- ["Running", "[" ++ ex, unwords (tail args) ++ "]"] - _ <- runNoLoggingT (exec menv ex (tail args)) + _ <- runNoLogging (exec menv ex (tail args)) return f Nothing -> return $ fmap (vcatErrorHelp (noSuchCmd cmd)) f where @@ -539,8 +553,7 @@ then overrideErrorHelp else vcatErrorHelp - overrideErrorHelp (ParserHelp e1 _ _ _ _) (ParserHelp _ h2 u2 b2 f2) = - ParserHelp e1 h2 u2 b2 f2 + overrideErrorHelp h1 h2 = h2 { helpError = helpError h1 } parseResultHandler fn = handleParseResult (overFailure fn (Failure f)) noSuchFile name = errorHelp $ stringChunk @@ -562,37 +575,38 @@ pathCmd keys go = withBuildConfig go (Stack.Path.path keys) setupCmd :: SetupCmdOpts -> GlobalOpts -> IO () -setupCmd sco@SetupCmdOpts{..} go@GlobalOpts{..} = do - lc <- loadConfigWithOpts go +setupCmd sco@SetupCmdOpts{..} go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> do when (isJust scoUpgradeCabal && nixEnable (configNix (lcConfig lc))) $ do throwIO UpgradeCabalUnusable withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do let getCompilerVersion = loadCompilerVersion go lc - runStackTGlobal (lcConfig lc) go $ + runRIO (lcConfig lc) $ Docker.reexecWithOptionalContainer (lcProjectRoot lc) Nothing - (runStackTGlobal (lcConfig lc) go $ - Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion $ - runStackTGlobal () go $ do - (wantedCompiler, compilerCheck, mstack) <- - case scoCompilerVersion of - Just v -> return (v, MatchMinor, Nothing) - Nothing -> do - bc <- lcLoadBuildConfig lc globalCompiler - return ( view wantedCompilerVersionL bc - , configCompilerCheck (lcConfig lc) - , Just $ view stackYamlL bc - ) - let miniConfig = loadMiniConfig (lcConfig lc) - runStackTGlobal miniConfig go $ - setup sco wantedCompiler compilerCheck mstack - ) + (runRIO (lcConfig lc) $ + Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion $ do + (wantedCompiler, compilerCheck, mstack) <- + case scoCompilerVersion of + Just v -> return (v, MatchMinor, Nothing) + Nothing -> do + bc <- liftIO $ lcLoadBuildConfig lc globalCompiler + return ( view wantedCompilerVersionL bc + , configCompilerCheck (lcConfig lc) + , Just $ view stackYamlL bc + ) + runRIO (loadMiniConfig (lcConfig lc)) $ setup sco wantedCompiler compilerCheck mstack + ) Nothing (Just $ munlockFile lk) cleanCmd :: CleanOpts -> GlobalOpts -> IO () -cleanCmd opts go = withBuildConfigAndLockNoDocker go (const (clean opts)) +cleanCmd opts go = + -- See issues #2010 and #3468 for why "stack clean --full" is not used + -- within docker. + case opts of + CleanFull{} -> withBuildConfigAndLock go (const (clean opts)) + CleanShallow{} -> withBuildConfigAndLockNoDocker go (const (clean opts)) -- | Helper for build and install commands buildCmd :: BuildOptsCLI -> GlobalOpts -> IO () @@ -618,27 +632,19 @@ Build -> go -- Default case is just Build uninstallCmd :: [String] -> GlobalOpts -> IO () -uninstallCmd _ go = withConfigAndLock go $ do - $logError "stack does not manage installations in global locations" - $logError "The only global mutation stack performs is executable copying" - $logError "For the default executable destination, please run 'stack path --local-bin'" +uninstallCmd _ go = withConfigAndLock go $ + prettyErrorL + [ flow "stack does not manage installations in global locations." + , flow "The only global mutation stack performs is executable copying." + , flow "For the default executable destination, please run" + , styleShell "stack path --local-bin" + ] -- | Unpack packages to the filesystem unpackCmd :: [String] -> GlobalOpts -> IO () unpackCmd names go = withConfigAndLock go $ do - mMiniBuildPlan <- - case globalResolver go of - Nothing -> return Nothing - Just ar -> fmap Just $ do - r <- makeConcreteResolver ar - case r of - ResolverSnapshot snapName -> do - config <- view configL - let miniConfig = loadMiniConfig config - runInnerStackT miniConfig (loadMiniBuildPlan snapName) - ResolverCompiler _ -> throwString "Error: unpack does not work with compiler resolvers" - ResolverCustom _ _ -> throwString "Error: unpack does not work with custom resolvers" - Stack.Fetch.unpackPackages mMiniBuildPlan "." names + mSnapshotDef <- mapM (makeConcreteResolver Nothing >=> loadResolver) (globalResolver go) + Stack.Fetch.unpackPackages mSnapshotDef "." names -- | Update the package index updateCmd :: () -> GlobalOpts -> IO () @@ -657,7 +663,12 @@ -- | Upload to Hackage uploadCmd :: SDistOpts -> GlobalOpts -> IO () -uploadCmd (SDistOpts [] _ _ _ _ _) _ = throwString "Error: To upload the current package, please run 'stack upload .'" +uploadCmd (SDistOpts [] _ _ _ _ _) go = + withConfigAndLock go . prettyErrorL $ + [ flow "To upload the current package, please run" + , styleShell "stack upload ." + , flow "(with the period at the end)" + ] uploadCmd sdistOpts go = do let partitionM _ [] = return ([], []) partitionM f (x:xs) = do @@ -666,12 +677,22 @@ return $ if r then (x:as, bs) else (as, x:bs) (files, nonFiles) <- partitionM D.doesFileExist (sdoptsDirsToWorkWith sdistOpts) (dirs, invalid) <- partitionM D.doesDirectoryExist nonFiles - unless (null invalid) $ do - hPutStrLn stderr $ - "Error: stack upload expects a list sdist tarballs or cabal directories. Can't find " ++ - show invalid - exitFailure withBuildConfigAndLock go $ \_ -> do + unless (null invalid) $ do + let invalidList = bulletedList $ map (styleFile . fromString) invalid + prettyErrorL + [ styleShell "stack upload" + , flow "expects a list of sdist tarballs or package directories." + , flow "Can't find:" + , line <> invalidList + ] + liftIO exitFailure + when (null files && null dirs) $ do + prettyErrorL + [ styleShell "stack upload" + , flow "expects a list of sdist tarballs or package directories, but none were specified." + ] + liftIO exitFailure config <- view configL getCreds <- liftIO (runOnce (Upload.loadCreds config)) mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files @@ -711,7 +732,19 @@ withBuildConfig go $ do -- No locking needed. -- If no directories are specified, build all sdist tarballs. dirs' <- if null (sdoptsDirsToWorkWith sdistOpts) - then liftM Map.keys getLocalPackages + then do + dirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages + when (null dirs) $ do + stackYaml <- view stackYamlL + prettyErrorL + [ styleShell "stack sdist" + , flow "expects a list of targets, and otherwise defaults to all of the project's packages." + , flow "However, the configuration at" + , display stackYaml + , flow "contains no packages, so no sdist tarballs will be generated." + ] + liftIO exitFailure + return dirs else mapM resolveDir' (sdoptsDirsToWorkWith sdistOpts) forM_ dirs' $ \dir -> do (tarName, tarBytes, _mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) dir @@ -720,7 +753,7 @@ ensureDir (parent tarPath) liftIO $ L.writeFile (toFilePath tarPath) tarBytes checkSDistTarball sdistOpts tarPath - $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath) + prettyInfoL [flow "Wrote sdist tarball to", display tarPath] when (sdoptsSign sdistOpts) (void $ Sig.sign (sdoptsSignServerUrl sdistOpts) tarPath) -- | Execute a command. @@ -728,25 +761,25 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = case eoExtra of ExecOptsPlain -> do - (cmd, args) <- case (eoCmd, eoArgs) of + (cmd, args) <- case (eoCmd, eoArgs) of (ExecCmd cmd, args) -> return (cmd, args) (ExecGhc, args) -> return ("ghc", args) (ExecRunGhc, args) -> return ("runghc", args) - lc <- liftIO $ loadConfigWithOpts go + loadConfigWithOpts go $ \lc -> withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do let getCompilerVersion = loadCompilerVersion go lc - runStackTGlobal (lcConfig lc) go $ + runRIO (lcConfig lc) $ Docker.reexecWithOptionalContainer (lcProjectRoot lc) -- Unlock before transferring control away, whether using docker or not: (Just $ munlockFile lk) - (runStackTGlobal (lcConfig lc) go $ do + (runRIO (lcConfig lc) $ do config <- view configL menv <- liftIO $ configEnvOverride config plainEnvSettings Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion - (runStackTGlobal (lcConfig lc) go $ + (runRIO (lcConfig lc) $ exec menv cmd args)) Nothing Nothing -- Unlocked already above. @@ -772,7 +805,8 @@ (ExecRunGhc, args) -> getGhcCmd "run" menv eoPackages args munlockFile lk -- Unlock before transferring control away. - exec menv cmd args + + runWithPath eoCwd $ exec menv cmd args where -- return the package-id of the first package in GHC_PACKAGE_PATH getPkgId menv wc name = do @@ -793,6 +827,12 @@ pkgopts <- getPkgOpts menv wc pkgs return (prefix ++ compilerExeName wc, pkgopts ++ args) + runWithPath :: Maybe FilePath -> RIO EnvConfig () -> RIO EnvConfig () + runWithPath path callback = case path of + Nothing -> callback + Just p | not (isValid p) -> throwIO $ InvalidPathForExec p + Just p -> withUnliftIO $ \ul -> D.withCurrentDirectory p $ unliftIO ul callback + -- | Evaluate some haskell code inline. evalCmd :: EvalOpts -> GlobalOpts -> IO () evalCmd EvalOpts {..} go@GlobalOpts {..} = execCmd execOpts go @@ -829,29 +869,29 @@ -- | Pull the current Docker image. dockerPullCmd :: () -> GlobalOpts -> IO () -dockerPullCmd _ go@GlobalOpts{..} = do - lc <- liftIO $ loadConfigWithOpts go +dockerPullCmd _ go@GlobalOpts{..} = + loadConfigWithOpts go $ \lc -> -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/? withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ -> - runStackTGlobal (lcConfig lc) go $ + runRIO (lcConfig lc) $ Docker.preventInContainer Docker.pull -- | Reset the Docker sandbox. dockerResetCmd :: Bool -> GlobalOpts -> IO () -dockerResetCmd keepHome go@GlobalOpts{..} = do - lc <- liftIO (loadConfigWithOpts go) +dockerResetCmd keepHome go@GlobalOpts{..} = + loadConfigWithOpts go $ \lc -> -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/? withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ -> - runStackTGlobal (lcConfig lc) go $ + runRIO (lcConfig lc) $ Docker.preventInContainer $ Docker.reset (lcProjectRoot lc) keepHome -- | Cleanup Docker images and containers. dockerCleanupCmd :: Docker.CleanupOpts -> GlobalOpts -> IO () -dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = do - lc <- liftIO $ loadConfigWithOpts go +dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = + loadConfigWithOpts go $ \lc -> -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/? withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ -> - runStackTGlobal (lcConfig lc) go $ + runRIO (lcConfig lc) $ Docker.preventInContainer $ Docker.cleanup cleanupOpts @@ -862,8 +902,8 @@ (cfgCmdSet go co) imgDockerCmd :: (Bool, [Text]) -> GlobalOpts -> IO () -imgDockerCmd (rebuild,images) go@GlobalOpts{..} = do - mProjectRoot <- lcProjectRoot <$> loadConfigWithOpts go +imgDockerCmd (rebuild,images) go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> do + let mProjectRoot = lcProjectRoot lc withBuildConfigExt False go @@ -910,7 +950,7 @@ listDependenciesCmd opts go = withBuildConfigDot (listDepsDotOpts opts) go $ listDependencies opts -- Plumbing for --test and --bench flags -withBuildConfigDot :: DotOpts -> GlobalOpts -> StackT EnvConfig IO () -> IO () +withBuildConfigDot :: DotOpts -> GlobalOpts -> RIO EnvConfig () -> IO () withBuildConfigDot opts go f = withBuildConfig go' f where go' = @@ -928,6 +968,7 @@ data MainException = InvalidReExecVersion String String | UpgradeCabalUnusable + | InvalidPathForExec FilePath deriving (Typeable) instance Exception MainException instance Show MainException where @@ -939,3 +980,7 @@ , "; found: " , actual] show UpgradeCabalUnusable = "--upgrade-cabal cannot be used when nix is activated" + show (InvalidPathForExec path) = concat + [ "Got an invalid --cwd argument for stack exec (" + , path + , ")"] diff --git a/src/test/Network/HTTP/Download/VerifiedSpec.hs b/src/test/Network/HTTP/Download/VerifiedSpec.hs --- a/src/test/Network/HTTP/Download/VerifiedSpec.hs +++ b/src/test/Network/HTTP/Download/VerifiedSpec.hs @@ -1,15 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Network.HTTP.Download.VerifiedSpec where -import Control.Applicative import Control.Monad.Logger (runStdoutLoggingT) import Control.Retry (limitRetries) import Crypto.Hash -import Data.Maybe import Network.HTTP.Client.Conduit import Network.HTTP.Download.Verified import Path -import Path.IO -import Prelude -- Fix redundant imports warnings +import Path.IO hiding (withSystemTempDir) +import Stack.Prelude +import Stack.Types.Runner +import System.IO (writeFile, readFile) import Test.Hspec -- TODO: share across test files @@ -66,20 +67,23 @@ let exampleProgressHook _ = return () describe "verifiedDownload" $ do + let run func = runStdoutLoggingT + $ withRunner LevelError True True ColorNever Nothing False + $ \runner -> runRIO runner func -- Preconditions: -- * the exampleReq server is running -- * the test runner has working internet access to it it "downloads the file correctly" $ withTempDir' $ \dir -> do examplePath <- getExamplePath dir doesFileExist examplePath `shouldReturn` False - let go = runStdoutLoggingT $ verifiedDownload exampleReq examplePath exampleProgressHook + let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook go `shouldReturn` True doesFileExist examplePath `shouldReturn` True it "is idempotent, and doesn't redownload unnecessarily" $ withTempDir' $ \dir -> do examplePath <- getExamplePath dir doesFileExist examplePath `shouldReturn` False - let go = runStdoutLoggingT $ verifiedDownload exampleReq examplePath exampleProgressHook + let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook go `shouldReturn` True doesFileExist examplePath `shouldReturn` True go `shouldReturn` False @@ -92,7 +96,7 @@ writeFile exampleFilePath exampleWrongContent doesFileExist examplePath `shouldReturn` True readFile exampleFilePath `shouldReturn` exampleWrongContent - let go = runStdoutLoggingT $ verifiedDownload exampleReq examplePath exampleProgressHook + let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook go `shouldReturn` True doesFileExist examplePath `shouldReturn` True readFile exampleFilePath `shouldNotReturn` exampleWrongContent @@ -102,7 +106,7 @@ let wrongContentLengthReq = exampleReq { drLengthCheck = Just exampleWrongContentLength } - let go = runStdoutLoggingT $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook + let go = run $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook go `shouldThrow` isWrongContentLength doesFileExist examplePath `shouldReturn` False @@ -110,7 +114,7 @@ examplePath <- getExamplePath dir let wrongHashCheck = exampleHashCheck { hashCheckHexDigest = exampleWrongDigest } let wrongDigestReq = exampleReq { drHashChecks = [wrongHashCheck] } - let go = runStdoutLoggingT $ verifiedDownload wrongDigestReq examplePath exampleProgressHook + let go = run $ verifiedDownload wrongDigestReq examplePath exampleProgressHook go `shouldThrow` isWrongDigest doesFileExist examplePath `shouldReturn` False @@ -124,7 +128,7 @@ , drLengthCheck = Nothing , drRetryPolicy = limitRetries 1 } - let go = runStdoutLoggingT $ verifiedDownload dReq dest exampleProgressHook + let go = run $ verifiedDownload dReq dest exampleProgressHook doesFileExist dest `shouldReturn` False go `shouldReturn` True doesFileExist dest `shouldReturn` True diff --git a/src/test/Spec.hs b/src/test/Spec.hs --- a/src/test/Spec.hs +++ b/src/test/Spec.hs @@ -1,1 +1,2 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/src/test/Stack/ArgsSpec.hs b/src/test/Stack/ArgsSpec.hs --- a/src/test/Stack/ArgsSpec.hs +++ b/src/test/Stack/ArgsSpec.hs @@ -1,16 +1,17 @@ +{-# LANGUAGE NoImplicitPrelude #-} -- | Args parser test suite. module Stack.ArgsSpec where -import Control.Applicative -import Control.Exception.Base (assert) import Control.Monad +import Data.Attoparsec.Args (EscapingMode(..), parseArgsFromString) import Data.Attoparsec.Interpreter (interpreterArgsParser) import qualified Data.Attoparsec.Text as P import Data.Text (pack) -import Options.Applicative.Args import Stack.Constants (stackProgName) +import Stack.Prelude import Test.Hspec +import Prelude (head) -- | Test spec. spec :: Spec @@ -20,7 +21,7 @@ argsSpec :: Spec argsSpec = forM_ argsInputOutput - (\(input,output) -> it input (parseArgsFromString input == output)) + (\(input,output) -> it input (parseArgsFromString Escaping input == output)) -- | Fairly comprehensive checks. argsInputOutput :: [(String, Either String [String])] diff --git a/src/test/Stack/Build/ExecuteSpec.hs b/src/test/Stack/Build/ExecuteSpec.hs --- a/src/test/Stack/Build/ExecuteSpec.hs +++ b/src/test/Stack/Build/ExecuteSpec.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Build.ExecuteSpec (main, spec) where +import Stack.Prelude import Test.Hspec main :: IO () diff --git a/src/test/Stack/Build/TargetSpec.hs b/src/test/Stack/Build/TargetSpec.hs --- a/src/test/Stack/Build/TargetSpec.hs +++ b/src/test/Stack/Build/TargetSpec.hs @@ -1,13 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Stack.Build.TargetSpec (main, spec) where import qualified Data.Text as T import Stack.Build.Target +import Stack.Prelude +import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -import Stack.Types.Package import Test.Hspec main :: IO () diff --git a/src/test/Stack/BuildPlanSpec.hs b/src/test/Stack/BuildPlanSpec.hs deleted file mode 100644 --- a/src/test/Stack/BuildPlanSpec.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -module Stack.BuildPlanSpec where - -import Stack.BuildPlan -import Control.Monad.Logger -import Control.Exception hiding (try) -import Control.Monad.Catch (try) -import Data.Monoid -import qualified Data.Map as Map -import qualified Data.Set as Set -import Prelude -- Fix redundant import warnings -import System.Directory -import System.Environment -import System.IO.Temp (withSystemTempDirectory) -import Test.Hspec -import Stack.Config -import Stack.Types.BuildPlan -import Stack.Types.PackageName -import Stack.Types.Version -import Stack.Types.Config -import Stack.Types.Compiler -import Stack.Types.StackT - -setup :: IO () -setup = unsetEnv "STACK_YAML" - -main :: IO () -main = hspec spec - -spec :: Spec -spec = beforeAll setup $ do - let logLevel = LevelDebug - let loadConfig' = runStackT () logLevel True False ColorAuto False (loadConfig mempty Nothing SYLDefault) - let loadBuildConfigRest = runStackT () logLevel True False ColorAuto False - let inTempDir action = do - currentDirectory <- getCurrentDirectory - withSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do - let enterDir = setCurrentDirectory tempDir - let exitDir = setCurrentDirectory currentDirectory - bracket_ enterDir exitDir action - it "finds missing transitive dependencies #159" $ inTempDir $ do - -- Note: this test is somewhat fragile, depending on packages on - -- Hackage remaining in a certain state. If it fails, confirm that - -- github still depends on failure. - writeFile "stack.yaml" "resolver: lts-2.9" - LoadConfig{..} <- loadConfig' - bconfig <- loadBuildConfigRest (lcLoadBuildConfig Nothing) - runStackT bconfig logLevel True False ColorAuto False $ do - mbp <- loadMiniBuildPlan $ LTS 2 9 - eres <- try $ resolveBuildPlan - mbp - (const False) - (Map.fromList - [ ($(mkPackageName "github"), Set.empty) - ]) - case eres of - Left (UnknownPackages _ unknown _) -> do - case Map.lookup $(mkPackageName "github") unknown of - Nothing -> error "doesn't list github as unknown" - Just _ -> return () - - {- Currently not implemented, see: https://github.com/fpco/stack/issues/159#issuecomment-107809418 - case Map.lookup $(mkPackageName "failure") unknown of - Nothing -> error "failure not listed" - Just _ -> return () - -} - _ -> error $ "Unexpected result from resolveBuildPlan: " ++ show eres - return () - - describe "shadowMiniBuildPlan" $ do - let version = $(mkVersion "1.0.0") -- unimportant for this test - pn = either throw id . parsePackageNameFromString - mkMPI deps = MiniPackageInfo - { mpiVersion = version - , mpiFlags = Map.empty - , mpiGhcOptions = [] - , mpiPackageDeps = Set.fromList $ map pn $ words deps - , mpiToolDeps = Set.empty - , mpiExes = Set.empty - , mpiHasLibrary = True - , mpiGitSHA1 = Nothing - } - go x y = (pn x, mkMPI y) - resourcet = go "resourcet" "" - conduit = go "conduit" "resourcet" - conduitExtra = go "conduit-extra" "conduit" - text = go "text" "" - attoparsec = go "attoparsec" "text" - aeson = go "aeson" "text attoparsec" - mkMBP pkgs = MiniBuildPlan - { mbpCompilerVersion = GhcVersion version - , mbpPackages = Map.fromList pkgs - } - mbpAll = mkMBP [resourcet, conduit, conduitExtra, text, attoparsec, aeson] - test name input shadowed output extra = - it name $ const $ - shadowMiniBuildPlan input (Set.fromList $ map pn $ words shadowed) - `shouldBe` (output, Map.fromList extra) - test "no shadowing" mbpAll "" mbpAll [] - test "shadow something that isn't there" mbpAll "does-not-exist" mbpAll [] - test "shadow a leaf" mbpAll "conduit-extra" - (mkMBP [resourcet, conduit, text, attoparsec, aeson]) - [] - test "shadow direct dep" mbpAll "conduit" - (mkMBP [resourcet, text, attoparsec, aeson]) - [conduitExtra] - test "shadow deep dep" mbpAll "resourcet" - (mkMBP [text, attoparsec, aeson]) - [conduit, conduitExtra] - test "shadow deep dep and leaf" mbpAll "resourcet aeson" - (mkMBP [text, attoparsec]) - [conduit, conduitExtra] - test "shadow deep dep and direct dep" mbpAll "resourcet conduit" - (mkMBP [text, attoparsec, aeson]) - [conduitExtra] diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs --- a/src/test/Stack/ConfigSpec.hs +++ b/src/test/Stack/ConfigSpec.hs @@ -1,25 +1,20 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Stack.ConfigSpec where -import Control.Applicative -import Control.Exception -import Control.Monad.Logger import Data.Aeson.Extended -import Data.Either -import Data.Maybe -import Data.Monoid import Data.Yaml import Path -import Path.IO -import Prelude -- Fix redundant import warnings +import Path.IO hiding (withSystemTempDir) import Stack.Config +import Stack.Prelude import Stack.Types.Config -import Stack.Types.StackT +import Stack.Types.Runner import System.Directory import System.Environment -import System.IO.Temp (withSystemTempDirectory) +import System.IO (writeFile) import Test.Hspec sampleConfig :: String @@ -53,6 +48,12 @@ " reconfigure: true\n" ++ " cabal-verbose: true\n" +hpackConfig :: String +hpackConfig = + "resolver: lts-2.10\n" ++ + "with-hpack: /usr/local/bin/hpack\n" ++ + "packages: ['.']\n" + stackDotYaml :: Path Rel File stackDotYaml = $(mkRelFile "stack.yaml") @@ -80,21 +81,35 @@ bracket_ setVar resetVar action describe "loadConfig" $ do - let loadConfig' = runStackT () logLevel True False ColorAuto False (loadConfig mempty Nothing SYLDefault) - let loadBuildConfigRest = runStackT () logLevel True False ColorAuto False + let loadConfig' inner = + withRunner logLevel True False ColorAuto Nothing False $ \runner -> do + lc <- runRIO runner $ loadConfig mempty Nothing SYLDefault + inner lc -- TODO(danburton): make sure parent dirs also don't have config file - it "works even if no config file exists" $ example $ do - _config <- loadConfig' - return () + it "works even if no config file exists" $ example $ + loadConfig' $ const $ return () it "works with a blank config file" $ inTempDir $ do writeFile (toFilePath stackDotYaml) "" -- TODO(danburton): more specific test for exception - loadConfig' `shouldThrow` anyException + loadConfig' (const (return ())) `shouldThrow` anyException + it "parses config option with-hpack" $ inTempDir $ do + writeFile (toFilePath stackDotYaml) hpackConfig + loadConfig' $ \lc -> do + let Config{..} = lcConfig lc + configOverrideHpack `shouldBe` HpackCommand "/usr/local/bin/hpack" + + it "parses config bundled hpack" $ inTempDir $ do + writeFile (toFilePath stackDotYaml) sampleConfig + loadConfig' $ \lc -> do + let Config{..} = lcConfig lc + configOverrideHpack `shouldBe` HpackBundled + it "parses build config options" $ inTempDir $ do - writeFile (toFilePath stackDotYaml) buildOptsConfig - BuildOpts{..} <- configBuild . lcConfig <$> loadConfig' + writeFile (toFilePath stackDotYaml) buildOptsConfig + loadConfig' $ \lc -> do + let BuildOpts{..} = configBuild $ lcConfig lc boptsLibProfile `shouldBe` True boptsExeProfile `shouldBe` True boptsHaddock `shouldBe` True @@ -120,18 +135,16 @@ let childDir = "child" createDirectory childDir setCurrentDirectory childDir - LoadConfig{..} <- loadConfig' - bc <- loadBuildConfigRest (lcLoadBuildConfig Nothing) - view projectRootL bc `shouldBe` parentDir + loadConfig' $ \LoadConfig{..} -> do + bc <- liftIO (lcLoadBuildConfig Nothing) + view projectRootL bc `shouldBe` parentDir it "respects the STACK_YAML env variable" $ inTempDir $ do withSystemTempDir "config-is-here" $ \dir -> do let stackYamlFp = toFilePath (dir stackDotYaml) writeFile stackYamlFp sampleConfig - withEnvVar "STACK_YAML" stackYamlFp $ do - LoadConfig{..} <- loadConfig' - BuildConfig{..} <- loadBuildConfigRest - (lcLoadBuildConfig Nothing) + withEnvVar "STACK_YAML" stackYamlFp $ loadConfig' $ \LoadConfig{..} -> do + BuildConfig{..} <- lcLoadBuildConfig Nothing bcStackYaml `shouldBe` dir stackDotYaml parent bcStackYaml `shouldBe` dir @@ -142,10 +155,8 @@ yamlAbs = parentDir yamlRel createDirectoryIfMissing True $ toFilePath $ parent yamlAbs writeFile (toFilePath yamlAbs) "resolver: ghc-7.8" - withEnvVar "STACK_YAML" (toFilePath yamlRel) $ do - LoadConfig{..} <- loadConfig' - BuildConfig{..} <- loadBuildConfigRest - (lcLoadBuildConfig Nothing) + withEnvVar "STACK_YAML" (toFilePath yamlRel) $ loadConfig' $ \LoadConfig{..} -> do + BuildConfig{..} <- lcLoadBuildConfig Nothing bcStackYaml `shouldBe` yamlAbs describe "defaultConfigYaml" $ diff --git a/src/test/Stack/DotSpec.hs b/src/test/Stack/DotSpec.hs --- a/src/test/Stack/DotSpec.hs +++ b/src/test/Stack/DotSpec.hs @@ -1,19 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -- | Test suite for Stack.Dot module Stack.DotSpec where -import Control.Monad (filterM) -import Data.Foldable as F import Data.Functor.Identity import Data.List ((\\)) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) import Distribution.License (License (BSD3)) +import Stack.Prelude import Stack.Types.PackageName import Stack.Types.Version import Test.Hspec @@ -57,14 +54,14 @@ prop "requested packages are pruned" $ do let resolvedGraph = runIdentity (resolveDependencies Nothing graph stubLoader) - allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold (fmap fst g)) + allPackages g = Set.map show (Map.keysSet g `Set.union` fold (fmap fst g)) forAll (sublistOf (Set.toList (allPackages resolvedGraph))) $ \toPrune -> let pruned = pruneGraph [pkgName "one", pkgName "two"] toPrune resolvedGraph in Set.null (allPackages pruned `Set.intersection` Set.fromList toPrune) prop "pruning removes orhpans" $ do let resolvedGraph = runIdentity (resolveDependencies Nothing graph stubLoader) - allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold (fmap fst g)) + allPackages g = Set.map show (Map.keysSet g `Set.union` fold (fmap fst g)) orphans g = Map.filterWithKey (\k _ -> not (graphElem k g)) g forAll (sublistOf (Set.toList (allPackages resolvedGraph))) $ \toPrune -> let pruned = pruneGraph [pkgName "one", pkgName "two"] toPrune resolvedGraph diff --git a/src/test/Stack/Ghci/ScriptSpec.hs b/src/test/Stack/Ghci/ScriptSpec.hs --- a/src/test/Stack/Ghci/ScriptSpec.hs +++ b/src/test/Stack/Ghci/ScriptSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TemplateHaskell #-} @@ -11,6 +12,7 @@ import Test.Hspec import qualified System.FilePath as FP import Stack.Ghci.PortableFakePaths +import Stack.Prelude hiding (fromString) import Path import Path.Extra (pathToLazyByteString) @@ -25,23 +27,23 @@ it "should seperate commands with a newline" $ do let dir = $(mkAbsDir $ defaultDrive FP. "src" FP. "package-a") script = cmdCdGhc dir - <> cmdAdd [fromString "Lib.A"] + <> cmdAdd [Left (fromString "Lib.A")] scriptToLazyByteString script `shouldBe` ":cd-ghc " <> pathToLazyByteString dir <> "\n:add Lib.A\n" describe ":add" $ do it "should not render empty add commands" $ do - let script = cmdAdd [] + let script = cmdAdd S.empty scriptToLazyByteString script `shouldBe` "" it "should ensure that a space exists between each module in an add command" $ do - let script = cmdAdd (S.fromList [fromString "Lib.A", fromString "Lib.B"]) + let script = cmdAdd (S.fromList [Left (fromString "Lib.A"), Left (fromString "Lib.B")]) scriptToLazyByteString script `shouldBe` ":add Lib.A Lib.B\n" describe ":add (by file)" $ do it "should render a full file path" $ do let file = $(mkAbsFile $ defaultDrive FP. "Users" FP. "someone" FP. "src" FP. "project" FP. "package-a" FP. "src" FP. "Main.hs") - script = cmdAddFile file + script = cmdAdd (S.fromList [Right file]) scriptToLazyByteString script `shouldBe` ":add " <> pathToLazyByteString file <> "\n" diff --git a/src/test/Stack/GhciSpec.hs b/src/test/Stack/GhciSpec.hs --- a/src/test/Stack/GhciSpec.hs +++ b/src/test/Stack/GhciSpec.hs @@ -1,19 +1,27 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} +-- {-# LANGUAGE NoImplicitPrelude #-} +-- {-# LANGUAGE QuasiQuotes #-} +-- {-# LANGUAGE TemplateHaskell #-} -- | Test suite for GHCi like applications including both GHCi and Intero. module Stack.GhciSpec where +import Test.Hspec + +spec :: Spec +spec = return () + +{- Commented out as part of the fix for https://github.com/commercialhaskell/stack/issues/3309 + Not sure if maintaining this test is worth the effort. + import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as M import qualified Data.Set as S -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Distribution.License (License (BSD3)) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription (BuildType(..)) +import Stack.Prelude import Stack.Types.Package import Stack.Types.PackageName import Stack.Types.Version @@ -296,3 +304,4 @@ } } ] +-} diff --git a/src/test/Stack/NixSpec.hs b/src/test/Stack/NixSpec.hs --- a/src/test/Stack/NixSpec.hs +++ b/src/test/Stack/NixSpec.hs @@ -1,27 +1,25 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell, OverloadedStrings #-} module Stack.NixSpec where -import Control.Exception -import Control.Monad.Logger -import Data.Maybe -import Data.Monoid import Options.Applicative import Path -import Prelude -- to remove the warning about Data.Monoid being redundant on GHC 7.10 import Stack.Config import Stack.Options.NixParser import Stack.Config.Nix +import Stack.Prelude import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.Nix -import Stack.Types.StackT +import Stack.Types.Runner import Stack.Types.Version import System.Directory import System.Environment -import System.IO.Temp (withSystemTempDirectory) import Test.Hspec +import Prelude (writeFile) +import Data.Maybe (fromJust) sampleConfigNixEnabled :: String sampleConfigNixEnabled = @@ -47,7 +45,9 @@ spec :: Spec spec = beforeAll setup $ do - let loadConfig' cmdLineArgs = runStackT () LevelDebug True False ColorAuto False (loadConfig cmdLineArgs Nothing SYLDefault) + let loadConfig' cmdLineArgs = + withRunner LevelDebug True False ColorAuto Nothing False $ \runner -> + runRIO runner $ loadConfig cmdLineArgs Nothing SYLDefault inTempDir test = do currentDirectory <- getCurrentDirectory withSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do @@ -104,4 +104,5 @@ lc <- loadConfig' mempty nixPackages (configNix $ lcConfig lc) `shouldBe` ["glpk"] v <- parseVersion "7.10.3" - nixCompiler (GhcVersion v) `shouldBe` "haskell.compiler.ghc7103" + ghc <- either throwIO return $ nixCompiler (GhcVersion v) + ghc `shouldBe` "haskell.compiler.ghc7103" diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -1,22 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Stack.PackageDumpSpec where -import Control.Applicative -import Control.Monad.Logger -import Control.Monad.Trans.Resource (runResourceT) import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.Text (decodeUtf8) -import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.System (buildPlatform) import Distribution.License (License(..)) -import Prelude -- Fix redundant imports warnings import Stack.PackageDump +import Stack.Prelude import Stack.Types.Compiler import Stack.Types.GhcPkgId import Stack.Types.PackageIdentifier @@ -81,7 +78,7 @@ , "base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1" , "ghc-prim-0.3.1.0-a24f9c14c632d75b683d0f93283aea37" ] - haskell2010 `shouldBe` DumpPackage + haskell2010 { dpExposedModules = [] } `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = packageIdent , dpLicense = Just BSD3 @@ -95,6 +92,7 @@ , dpHaddock = () , dpSymbols = () , dpIsExposed = False + , dpExposedModules = [] } it "ghc 7.10" $ do @@ -121,7 +119,7 @@ , "transformers-0.4.2.0-c1a7bb855a176fe475d7b665301cd48f" , "unix-2.7.1.0-e5915eb989e568b732bc7286b0d0817f" ] - haskell2010 `shouldBe` DumpPackage + haskell2010 { dpExposedModules = [] } `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = pkgIdent , dpLicense = Just BSD3 @@ -135,6 +133,7 @@ , dpHaddock = () , dpSymbols = () , dpIsExposed = False + , dpExposedModules = [] } it "ghc 7.8.4 (osx)" $ do hmatrix:_ <- runResourceT @@ -172,6 +171,7 @@ , dpHaddock = () , dpSymbols = () , dpIsExposed = True + , dpExposedModules = ["Data.Packed","Data.Packed.Vector","Data.Packed.Matrix","Data.Packed.Foreign","Data.Packed.ST","Data.Packed.Development","Numeric.LinearAlgebra","Numeric.LinearAlgebra.LAPACK","Numeric.LinearAlgebra.Algorithms","Numeric.Container","Numeric.LinearAlgebra.Util","Numeric.LinearAlgebra.Devel","Numeric.LinearAlgebra.Data","Numeric.LinearAlgebra.HMatrix","Numeric.LinearAlgebra.Static"] } it "ghc HEAD" $ do ghcBoot:_ <- runResourceT @@ -203,10 +203,11 @@ , dpHaddock = () , dpSymbols = () , dpIsExposed = True + , dpExposedModules = ["GHC.Lexeme", "GHC.PackageDb"] } - it "ghcPkgDump + addProfiling + addHaddock" $ (id :: IO () -> IO ()) $ runNoLoggingT $ do + it "ghcPkgDump + addProfiling + addHaddock" $ (id :: IO () -> IO ()) $ runNoLogging $ do menv' <- getEnvOverride buildPlatform menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' icache <- newInstalledCache @@ -221,7 +222,7 @@ menv' <- getEnvOverride buildPlatform menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' icache <- newInstalledCache - m <- runNoLoggingT $ ghcPkgDump menv Ghc [] + m <- runNoLogging $ ghcPkgDump menv Ghc [] $ conduitDumpPackage =$ addProfiling icache =$ addHaddock icache diff --git a/src/test/Stack/SolverSpec.hs b/src/test/Stack/SolverSpec.hs --- a/src/test/Stack/SolverSpec.hs +++ b/src/test/Stack/SolverSpec.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} -- | Test suite for "Stack.Solver" module Stack.SolverSpec where import Data.Text (unpack) +import Stack.Prelude import Stack.Types.FlagName import Stack.Types.PackageName import Stack.Types.Version diff --git a/src/test/Stack/StaticBytesSpec.hs b/src/test/Stack/StaticBytesSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Stack/StaticBytesSpec.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Stack.StaticBytesSpec (spec) where + +import Stack.StaticBytes +import Stack.Prelude +import qualified Data.ByteString as B +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import Test.Hspec +import Test.Hspec.QuickCheck +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +spec :: Spec +spec = do + describe "ByteString" $ tests B.pack + describe "Storable Vector" $ tests VS.fromList + describe "Unboxed Vector" $ tests VU.fromList + describe "Primitive Vector" $ tests VP.fromList + +tests :: (Eq dbytes, Show dbytes, DynamicBytes dbytes) => ([Word8] -> dbytes) -> Spec +tests pack = do + it "disallows 4 bytes" $ do + toStaticExact (pack [1..4]) `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes8) + it "toStaticExact matches ByteString" $ do + let octets = [1..8] + (expected :: Bytes8) = either impureThrow id $ toStaticExact (B.pack octets) + actual = either impureThrow id $ toStaticExact (pack octets) + actual `shouldBe` expected + + it "fromStatic round trips" $ do + let octets = [1..8] + v1 = pack octets + (b8 :: Bytes8) = either impureThrow id $ toStaticExact v1 + v2 = fromStatic b8 + v2 `shouldBe` v1 + + it "allows 8 bytes" $ do + let bs = pack [1..8] + case toStaticExact bs of + Left e -> throwIO e + Right b8 -> fromStatic (b8 :: Bytes8) `shouldBe` bs + toStaticExact bs `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes16) + it "padding is the same as trailing nulls" $ do + let bs1 = pack $ [1..4] ++ replicate 4 0 + bs2 = pack [1..4] + Right (toStaticPadTruncate bs2 :: Bytes8) `shouldBe` toStaticExact bs1 + + prop "handles bytes16" $ \octets -> do + let bs = pack $ take 16 octets + (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs + fromStatic b16 `shouldBe` pack (take 16 (octets ++ replicate 16 0)) + + it "spot check bytes16" $ do + let bs = pack $ replicate 16 0 + (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs + fromStatic b16 `shouldBe` pack (replicate 16 0) + + prop "handles bytes32" $ \octets -> do + let bs = pack $ take 32 octets + (b32 :: Bytes32) = either impureThrow id $ toStaticPad bs + fromStatic b32 `shouldBe` pack (take 32 (take 32 octets ++ replicate 32 0)) + + prop "fuzz with encodeUtf8" $ \chars -> do + let t = T.pack $ filter (/= '\0') chars + bs = TE.encodeUtf8 t + bs128 = pack $ B.unpack $ B.take 128 $ bs `B.append` B.replicate 128 0 + b128 = toStaticPadTruncate (pack $ B.unpack bs) :: Bytes128 + + fromStatic b128 `shouldBe` bs128 diff --git a/src/test/Stack/StoreSpec.hs b/src/test/Stack/StoreSpec.hs --- a/src/test/Stack/StoreSpec.hs +++ b/src/test/Stack/StoreSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-orphans -Wwarn #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -7,26 +8,18 @@ {-# LANGUAGE OverloadedStrings #-} module Stack.StoreSpec where -import Control.Applicative import qualified Data.ByteString as BS import Data.Containers (mapFromList, setFromList) -import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap) -import Data.Int -import Data.Map (Map) import Data.Sequences (fromList) -import Data.Set (Set) +import Data.Store.Internal (StaticSize (..)) import Data.Store.TH -import Data.Text (Text) import qualified Data.Vector.Unboxed as UV -import Data.Word +import GHC.TypeLits (KnownNat) import Language.Haskell.TH import Language.Haskell.TH.ReifyMany -import Prelude +import Stack.Prelude import Stack.Types.Build -import Stack.Types.BuildPlan import Stack.Types.PackageDump -import Stack.Types.PackageIndex import Test.Hspec import Test.SmallCheck.Series @@ -51,6 +44,8 @@ instance (Monad m, Serial m a, Ord a) => Serial m (Set a) where series = fmap setFromList series +instance (Monad m, KnownNat n) => Serial m (StaticSize n BS.ByteString) + addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a] addMinAndMaxBounds xs = (if (minBound :: a) `notElem` xs then [minBound] else []) ++ @@ -63,8 +58,8 @@ concat <$> mapM f ns) $(do let tys = [ ''InstalledCacheInner - , ''PackageCacheMap - , ''MiniBuildPlan + -- FIXME , ''PackageCache + -- FIXME , ''LoadedSnapshot , ''BuildCache , ''ConfigCache ] @@ -83,10 +78,12 @@ , [t| BuildCache |] ]) -- Blows up with > 5 + {- $(smallcheckManyStore False 5 - [ [t| PackageCacheMap |] - , [t| MiniBuildPlan |] + [ -- FIXME [t| PackageCache |] + -- FIXME , [t| LoadedSnapshot |] ]) + -} -- Blows up with > 4 $(smallcheckManyStore False 4 [ [t| ConfigCache |] diff --git a/src/test/Stack/Untar/UntarSpec.hs b/src/test/Stack/Untar/UntarSpec.hs --- a/src/test/Stack/Untar/UntarSpec.hs +++ b/src/test/Stack/Untar/UntarSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -10,6 +11,7 @@ import Path.IO (removeDirRecur) import qualified System.FilePath as FP import Stack.Fetch (untar) +import Stack.Prelude import Test.Hspec spec :: Spec diff --git a/src/unix/System/Terminal.hsc b/src/unix/System/Terminal.hsc new file mode 100644 --- /dev/null +++ b/src/unix/System/Terminal.hsc @@ -0,0 +1,35 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.Terminal +( getTerminalWidth +) where + +import Foreign +import Foreign.C.Types + +#include +#include + +newtype WindowWidth = WindowWidth CUShort + deriving (Eq, Ord, Show) + +instance Storable WindowWidth where + sizeOf _ = (#size struct winsize) + alignment _ = (#alignment struct winsize) + peek p = WindowWidth <$> (#peek struct winsize, ws_col) p + poke p (WindowWidth w) = do + (#poke struct winsize, ws_col) p w + +foreign import ccall "sys/ioctl.h ioctl" + ioctl :: CInt -> CInt -> Ptr WindowWidth -> IO CInt + +-- | Get the width, in columns, of the terminal if we can. +getTerminalWidth :: IO (Maybe Int) +getTerminalWidth = + alloca $ \p -> do + errno <- ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) p + if errno < 0 + then return Nothing + else do + WindowWidth w <- peek p + return . Just . fromIntegral $ w diff --git a/src/windows/System/Terminal.hs b/src/windows/System/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/windows/System/Terminal.hs @@ -0,0 +1,6 @@ +module System.Terminal +( getTerminalWidth +) where +-- | Get the width, in columns, of the terminal if we can. +getTerminalWidth :: IO (Maybe Int) +getTerminalWidth = return Nothing diff --git a/stack.cabal b/stack.cabal --- a/stack.cabal +++ b/stack.cabal @@ -1,439 +1,668 @@ -name: stack -version: 1.5.1 -synopsis: The Haskell Tool Stack -description: Please see the README.md for usage information, and - the wiki on Github for more details. Also, note that - the API for the library is not currently stable, and may - change significantly, even between minor releases. It is - currently only intended for use by the executable. -license: BSD3 -license-file: LICENSE -author: Commercial Haskell SIG -maintainer: manny@fpcomplete.com -category: Development -build-type: Custom -cabal-version: >=1.10 -homepage: http://haskellstack.org -extra-source-files: CONTRIBUTING.md - ChangeLog.md - README.md - doc/*.md - src/setup-shim/StackSetupShim.hs - - -- Glob would be nice, but apparently Cabal doesn't support it: - -- cabal: filepath wildcard 'test/package-dump/*.txt' does not match any files. - -- Happened during cabal sdist - test/package-dump/ghc-7.8.txt - test/package-dump/ghc-7.8.4-osx.txt - test/package-dump/ghc-7.10.txt - - stack.yaml - -custom-setup - setup-depends: base - , Cabal - , filepath - -flag integration-tests - manual: True - default: False - description: Run the integration test suite - -flag disable-git-info - manual: True - default: False - description: Disable compile-time inclusion of current git info in stack - -- disabling git info can lead to a quicker workflow in certain - -- scenarios when you're developing on stack itself, but - -- should otherwise be avoided - -- see: https://github.com/commercialhaskell/stack/issues/1425 - -flag static - manual: True - default: False - description: Pass -static/-pthread to ghc when linking the stack binary. - -- Not intended for general use. Simply makes it easier to - -- build a fully static binary on Linux platforms that enable it. - -flag hide-dependency-versions - manual: True - default: False - description: Hides dependency versions from "stack --version", used only by building with stack.yaml - -library - hs-source-dirs: src/ - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-identities - exposed-modules: Control.Concurrent.Execute - Data.Aeson.Extended - Data.Attoparsec.Args - Data.Attoparsec.Combinators - Data.Attoparsec.Interpreter - Data.IORef.RunOnce - Data.Maybe.Extra - Data.Monoid.Extra - Data.Store.VersionTagged - Data.Text.Extra - Distribution.Version.Extra - Network.HTTP.Download - Network.HTTP.Download.Verified - Options.Applicative.Args - Options.Applicative.Builder.Extra - Options.Applicative.Complicated - Path.CheckInstall - Path.Extra - Path.Find - Paths_stack - Stack.Build - Stack.Build.Cache - Stack.Build.ConstructPlan - Stack.Build.Execute - Stack.Build.Haddock - Stack.Build.Installed - Stack.Build.Source - Stack.Build.Target - Stack.BuildPlan - Stack.Clean - Stack.Config - Stack.Config.Build - Stack.Config.Urls - Stack.Config.Docker - Stack.Config.Nix - Stack.ConfigCmd - Stack.Constants - Stack.Coverage - Stack.Docker - Stack.Docker.GlobalDB - Stack.Dot - Stack.Exec - Stack.Fetch - Stack.FileWatch - Stack.GhcPkg - Stack.Ghci - Stack.Ghci.Script - Stack.Hoogle - Stack.IDE - Stack.Image - Stack.Init - Stack.New - Stack.Nix - Stack.Options.BenchParser - Stack.Options.BuildMonoidParser - Stack.Options.BuildParser - Stack.Options.CleanParser - Stack.Options.ConfigParser - Stack.Options.Completion - Stack.Options.DockerParser - Stack.Options.DotParser - Stack.Options.ExecParser - Stack.Options.GhcBuildParser - Stack.Options.GhciParser - Stack.Options.GhcVariantParser - Stack.Options.GlobalParser - Stack.Options.HaddockParser - Stack.Options.HpcReportParser - Stack.Options.LogLevelParser - Stack.Options.NewParser - Stack.Options.NixParser - Stack.Options.PackageParser - Stack.Options.ResolverParser - Stack.Options.ScriptParser - Stack.Options.SDistParser - Stack.Options.SolverParser - Stack.Options.TestParser - Stack.Options.Utils - Stack.Package - Stack.PackageDump - Stack.PackageIndex - Stack.Path - Stack.PrettyPrint - Stack.Runners - Stack.Script - Stack.SDist - Stack.Setup - Stack.Setup.Installed - Stack.SetupCmd - Stack.Sig - Stack.Sig.GPG - Stack.Sig.Sign - Stack.Solver - Stack.Types.Build - Stack.Types.BuildPlan - Stack.Types.CompilerBuild - Stack.Types.Urls - Stack.Types.Compiler - Stack.Types.Config - Stack.Types.Config.Build - Stack.Types.Docker - Stack.Types.FlagName - Stack.Types.GhcPkgId - Stack.Types.Image - Stack.Types.Internal - Stack.Types.Nix - Stack.Types.Package - Stack.Types.PackageDump - Stack.Types.PackageIdentifier - Stack.Types.PackageIndex - Stack.Types.PackageName - Stack.Types.Resolver - Stack.Types.Sig - Stack.Types.StackT - Stack.Types.StringError - Stack.Types.TemplateName - Stack.Types.Version - Stack.Upgrade - Stack.Upload - Text.PrettyPrint.Leijen.Extended - System.Process.Log - System.Process.PagerEditor - System.Process.Read - System.Process.Run - other-modules: Hackage.Security.Client.Repository.HttpLib.HttpClient - build-depends: Cabal >= 1.24 && < 1.25 - , aeson (>= 1.0 && < 1.2) - , ansi-terminal >= 0.6.2.3 - , async >= 2.0.2 && < 2.2 - , attoparsec >= 0.12.1.5 && < 0.14 - , base >= 4.8 && <5 - , base-compat >=0.6 && <0.10 - , base64-bytestring - , binary >= 0.7 && < 0.9 - , binary-tagged >= 0.1.1 - , blaze-builder - , bytestring >= 0.10.4.0 - , clock >= 0.7.2 - , conduit >= 1.2.8 - , conduit-extra >= 1.1.14 - , containers >= 0.5.5.1 - , cryptonite >= 0.19 && < 0.24 - , cryptonite-conduit >= 0.1 && < 0.3 - , directory >= 1.2.1.0 && < 1.4 - , echo >= 0.1.3 && < 0.2 - , either - , errors < 2.3 - , exceptions >= 0.8.0.2 - , extra >= 1.4.10 && < 1.6 - , fast-logger >= 2.3.1 - , filelock >= 0.1.0.1 - , filepath >= 1.3.0.2 - , fsnotify >= 0.2.1 - , generic-deriving >= 1.10.5 && < 1.12 - , ghc-prim >= 0.4.0.0 - , hackage-security - , hashable >= 1.2.3.2 - , hpc >= 0.6.0.2 - , http-client >= 0.5.3.3 - , http-client-tls >= 0.3.4 - , http-conduit >= 2.2.3 - , http-types >= 0.8.6 && < 0.10 - , lifted-async >= 0.9.1.1 - -- https://github.com/basvandijk/lifted-base/issues/31 - , lifted-base < 0.2.3.7 || > 0.2.3.7 - , memory >= 0.13 && < 0.15 - , microlens >= 0.3.0.0 - , microlens-mtl >= 0.1.10.0 - , mintty >= 0.1.1 - , monad-control >= 1.0.1.0 - , monad-logger >= 0.3.13.1 - , monad-unlift < 0.3 - , mtl >= 2.1.3.1 - , network-uri - , open-browser >= 0.2.1 - , optparse-applicative >= 0.13 && < 0.14 - , path >= 0.5.8 && < 0.6 - , path-io >= 1.1.0 && < 2.0.0 - , persistent >= 2.1.2 && < 2.8 - -- persistent-sqlite-2.5.0.1 has a bug - -- (see https://github.com/yesodweb/persistent/pull/561#issuecomment-222329087) - , persistent-sqlite (>= 2.1.4 && < 2.5.0.1) || (> 2.5.0.1 && < 2.7) - , persistent-template >= 2.1.1 && < 2.6 - , pretty >= 1.1.1.1 - , process >= 1.2.1.0 && < 1.5 - , regex-applicative-text >=0.1.0.1 && <0.2 - , resourcet >= 1.1.4.1 - , retry >= 0.6 && < 0.8 - , safe >= 0.3 - , safe-exceptions >= 0.1.5.0 - , semigroups >= 0.5 && < 0.19 - , split - , stm >= 2.4.4 - , streaming-commons >= 0.1.10.0 - , tar >= 0.5.0.3 && < 0.6 - , template-haskell >= 2.9.0.0 && < 2.12 - , temporary >= 1.2.0.3 - , text >= 1.2.0.4 - , text-binary - , text-metrics >= 0.1 && < 0.4 - , time >= 1.4.2 && < 1.7 - , tls >= 1.3.8 - , transformers >= 0.3.0.0 && < 0.6 - , transformers-base >= 0.4.4 - , unicode-transforms >= 0.1 && <0.4 - , unix-compat >= 0.4.1.4 - , unordered-containers >= 0.2.5.1 - , vector >= 0.10.12.3 && < 0.13 - , vector-binary-instances - , yaml >= 0.8.20 - , zlib >= 0.5.4.2 && < 0.7 - , deepseq >= 1.4 - , hastache - , project-template >= 0.2 - , zip-archive >= 0.2.3.7 && < 0.4 - , hpack >= 0.17.0 && < 0.19 - , store >= 0.4.1 && < 0.5 - , store-core >= 0.4 && < 0.5 - , annotated-wl-pprint - , file-embed >= 0.0.10 - if os(windows) - cpp-options: -DWINDOWS - build-depends: Win32 - else - build-depends: unix >= 2.7.0.1 - , pid1 >= 0.1 && < 0.2 - default-language: Haskell2010 - -executable stack - hs-source-dirs: src/main - main-is: Main.hs - ghc-options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates - other-modules: Paths_stack - if flag(static) - ld-options: -static -pthread - - build-depends: Cabal >= 1.18.1.5 && < 1.25 - , base >=4.7 && < 5 - , bytestring >= 0.10.4.0 - , conduit >= 1.2.8 - , containers >= 0.5.5.1 - , directory >= 1.2.1.0 && < 1.4 - , either - , filelock >= 0.1.0.1 - , filepath >= 1.3.0.2 - , hpack >= 0.17.0 && < 0.19 - , http-client >= 0.5.3.3 - -- https://github.com/basvandijk/lifted-base/issues/31 - , lifted-base < 0.2.3.7 || > 0.2.3.7 - , microlens >= 0.3.0.0 - , monad-control >= 1.0.1.0 - , monad-logger >= 0.3.13.1 - , mtl >= 2.1.3.1 - , optparse-applicative >= 0.13 && < 0.14 - , path >= 0.5.8 && < 0.6 - , path-io >= 1.1.0 && < 2.0.0 - , split - , stack - , text >= 1.2.0.4 - , transformers >= 0.3.0.0 && < 0.6 - default-language: Haskell2010 - if os(windows) - build-depends: Win32 - cpp-options: -DWINDOWS - if !flag(disable-git-info) - cpp-options: -DUSE_GIT_INFO - build-depends: gitrev >= 1.1 && < 1.4 - , optparse-simple >= 0.0.3 - if flag(hide-dependency-versions) - cpp-options: -DHIDE_DEP_VERSIONS - -test-suite stack-test - type: exitcode-stdio-1.0 - hs-source-dirs: src/test - main-is: Test.hs - other-modules: Spec - , Stack.BuildPlanSpec - , Stack.Build.ExecuteSpec - , Stack.Build.TargetSpec - , Stack.ConfigSpec - , Stack.DotSpec - , Stack.GhciSpec - , Stack.Ghci.ScriptSpec - , Stack.Ghci.PortableFakePaths - , Stack.PackageDumpSpec - , Stack.ArgsSpec - , Stack.NixSpec - , Stack.StoreSpec - , Network.HTTP.Download.VerifiedSpec - , Stack.SolverSpec - , Stack.Untar.UntarSpec - ghc-options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates - build-depends: Cabal >= 1.18.1.5 && < 1.25 - , QuickCheck >= 2.8.2 && < 2.10 - , attoparsec < 0.14 - , base >=4.7 && <5 - , conduit >= 1.2.8 - , conduit-extra - , containers >= 0.5.5.1 - , cryptonite >= 0.19 && < 0.24 - , directory >= 1.2.1.0 && < 1.4 - , exceptions - , filepath >= 1.3.0.2 - , hspec >= 2.2 && <2.5 - , hashable >= 1.2.3.2 - , http-client-tls >= 0.3.4 - , http-conduit >= 2.2.3 - , monad-logger - , neat-interpolation >= 0.3 - , optparse-applicative >= 0.13 && < 0.14 - , path >= 0.5.8 && < 0.6 - , path-io >= 1.1.0 && < 2.0.0 - , resourcet - , retry >= 0.6 && < 0.8 - , stack - , temporary >= 1.2.0.3 - , text - , transformers >= 0.3.0.0 && < 0.6 - , mono-traversable >= 0.10.2 && <1.1 - , th-reify-many >= 0.1.6 - , smallcheck - , bytestring >= 0.10.4.0 - , store >= 0.4.1 && < 0.5 - , vector >= 0.10.12.3 && < 0.13 - , unordered-containers - , template-haskell >= 2.9.0.0 && < 2.12 - , yaml >= 0.8.20 - default-language: Haskell2010 - if os(windows) - cpp-options: -DWINDOWS - -test-suite stack-integration-test - type: exitcode-stdio-1.0 - hs-source-dirs: test/integration - main-is: IntegrationSpec.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates - - if !flag(integration-tests) - buildable: False - - build-depends: async < 2.2 - , base >= 4.7 && < 5 - , bytestring >= 0.10.4.0 - , conduit >= 1.2.8 - , conduit-extra >= 1.1.14 - , containers >= 0.5.5.1 - , directory >= 1.2.1.0 && < 1.4 - , filepath >= 1.3.0.2 - , hspec >= 2.2 && < 2.5 - , process >= 1.2.0.0 && < 1.5 - , resourcet - , temporary >= 1.2.0.3 - , text - , transformers >= 0.3.0.0 && < 0.6 - , unix-compat >= 0.4.1.4 - default-language: Haskell2010 - - -- This isn't actually needed to build stack-integration-test, but it makes it - -- easier to load up an individual integration test into stack ghci. It's - -- still a little involved: - -- - -- stack exec -- stack ghci stack:stack-integration-test --flag stack:integration-tests --no-build - -- - -- Then, in ghci: - -- - -- :cd test/integration/tests/.../files - -- :load ../Main.hs - -- main - other-modules: StackTest - hs-source-dirs: test/integration/lib - -source-repository head - type: git - location: https://github.com/commercialhaskell/stack.git +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: d149de7c99c88786c765e40f4d0f24a47010c288e64c6cb556d989a04a0df537 + +name: stack +version: 1.6.1 +synopsis: The Haskell Tool Stack +description: Please see the README.md for usage information, and the wiki on Github for more details. Also, note that the API for the library is not currently stable, and may change significantly, even between minor releases. It is currently only intended for use by the executable. +category: Development +homepage: http://haskellstack.org +bug-reports: https://github.com/commercialhaskell/stack.git/issues +author: Commercial Haskell SIG +maintainer: manny@fpcomplete.com +license: BSD3 +license-file: LICENSE +build-type: Custom +cabal-version: >= 1.10 + +extra-source-files: + ChangeLog.md + CONTRIBUTING.md + doc/architecture.md + doc/build_command.md + doc/ChangeLog.md + doc/CONTRIBUTING.md + doc/coverage.md + doc/custom_snapshot.md + doc/dependency_visualization.md + doc/docker_integration.md + doc/faq.md + doc/ghci.md + doc/ghcjs.md + doc/GUIDE.md + doc/install_and_upgrade.md + doc/MAINTAINER_GUIDE.md + doc/nix_integration.md + doc/nonstandard_project_init.md + doc/README.md + doc/shell_autocompletion.md + doc/SIGNING_KEY.md + doc/travis_ci.md + doc/yaml_configuration.md + package.yaml + README.md + src/setup-shim/StackSetupShim.hs + stack.yaml + test/package-dump/ghc-7.10.txt + test/package-dump/ghc-7.8.4-osx.txt + test/package-dump/ghc-7.8.txt + +source-repository head + type: git + location: https://github.com/commercialhaskell/stack.git + +custom-setup + setup-depends: + Cabal + , base + , filepath + +flag disable-git-info + description: Disable compile-time inclusion of current git info in stack + manual: True + default: False + +flag hide-dependency-versions + description: Hides dependency versions from "stack --version", used only by building with stack.yaml + manual: True + default: False + +flag integration-tests + description: Run the integration test suite + manual: True + default: False + +flag static + description: Pass -static/-pthread to ghc when linking the stack binary. + manual: True + default: False + +flag supported-build + description: If false, causes "stack --version" to issue a warning about the build being unsupported. True only if building with stack.yaml + manual: True + default: False + +library + hs-source-dirs: + src/ + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-identities + build-depends: + Cabal + , aeson + , annotated-wl-pprint + , ansi-terminal + , async + , attoparsec + , base >=4.9 && <5 + , base64-bytestring + , blaze-builder + , bytestring + , clock + , conduit + , conduit-extra + , containers + , cryptonite + , cryptonite-conduit + , deepseq + , directory + , echo + , exceptions + , extra + , fast-logger + , file-embed + , filelock + , filepath + , fsnotify + , generic-deriving + , hackage-security + , hashable + , hastache + , hpack + , hpc + , http-client + , http-client-tls + , http-conduit + , http-types + , memory + , microlens + , microlens-mtl + , mintty + , monad-logger + , mono-traversable + , mtl + , neat-interpolation + , network-uri + , open-browser + , optparse-applicative + , path + , path-io + , persistent + , persistent-sqlite + , persistent-template + , pretty + , primitive + , process + , project-template + , regex-applicative-text + , resourcet + , retry + , semigroups + , split + , stm + , store + , store-core + , streaming-commons + , tar + , template-haskell + , temporary + , text + , text-metrics + , th-reify-many + , time + , tls + , transformers + , unicode-transforms + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + , zlib + if os(windows) + cpp-options: -DWINDOWS + build-depends: + Win32 + else + build-depends: + bindings-uname + , pid1 + , unix + build-tools: + hsc2hs + if os(windows) + hs-source-dirs: + src/windows/ + else + hs-source-dirs: + src/unix/ + exposed-modules: + Control.Concurrent.Execute + Data.Aeson.Extended + Data.Attoparsec.Args + Data.Attoparsec.Combinators + Data.Attoparsec.Interpreter + Data.IORef.RunOnce + Data.Store.VersionTagged + Network.HTTP.Download + Network.HTTP.Download.Verified + Options.Applicative.Args + Options.Applicative.Builder.Extra + Options.Applicative.Complicated + Path.CheckInstall + Path.Extra + Path.Find + Paths_stack + Stack.Build + Stack.Build.Cache + Stack.Build.ConstructPlan + Stack.Build.Execute + Stack.Build.Haddock + Stack.Build.Installed + Stack.Build.Source + Stack.Build.Target + Stack.BuildPlan + Stack.Clean + Stack.Config + Stack.Config.Build + Stack.Config.Urls + Stack.Config.Docker + Stack.Config.Nix + Stack.ConfigCmd + Stack.Constants + Stack.Constants.Config + Stack.Coverage + Stack.Docker + Stack.Docker.GlobalDB + Stack.Dot + Stack.Exec + Stack.Fetch + Stack.FileWatch + Stack.GhcPkg + Stack.Ghci + Stack.Ghci.Script + Stack.Hoogle + Stack.IDE + Stack.Image + Stack.Init + Stack.New + Stack.Nix + Stack.Options.BenchParser + Stack.Options.BuildMonoidParser + Stack.Options.BuildParser + Stack.Options.CleanParser + Stack.Options.ConfigParser + Stack.Options.Completion + Stack.Options.DockerParser + Stack.Options.DotParser + Stack.Options.ExecParser + Stack.Options.GhcBuildParser + Stack.Options.GhciParser + Stack.Options.GhcVariantParser + Stack.Options.GlobalParser + Stack.Options.HaddockParser + Stack.Options.HpcReportParser + Stack.Options.LogLevelParser + Stack.Options.NewParser + Stack.Options.NixParser + Stack.Options.PackageParser + Stack.Options.ResolverParser + Stack.Options.ScriptParser + Stack.Options.SDistParser + Stack.Options.SolverParser + Stack.Options.TestParser + Stack.Options.Utils + Stack.Package + Stack.PackageDump + Stack.PackageIndex + Stack.PackageLocation + Stack.Path + Stack.Prelude + Stack.PrettyPrint + Stack.Runners + Stack.Script + Stack.SDist + Stack.Setup + Stack.Setup.Installed + Stack.SetupCmd + Stack.Sig + Stack.Sig.GPG + Stack.Sig.Sign + Stack.Snapshot + Stack.Solver + Stack.StaticBytes + Stack.Types.Build + Stack.Types.BuildPlan + Stack.Types.CompilerBuild + Stack.Types.Urls + Stack.Types.Compiler + Stack.Types.Config + Stack.Types.Config.Build + Stack.Types.Docker + Stack.Types.FlagName + Stack.Types.GhcPkgId + Stack.Types.Image + Stack.Types.Nix + Stack.Types.Package + Stack.Types.PackageDump + Stack.Types.PackageIdentifier + Stack.Types.PackageIndex + Stack.Types.PackageName + Stack.Types.Resolver + Stack.Types.Runner + Stack.Types.Sig + Stack.Types.TemplateName + Stack.Types.Version + Stack.Types.VersionIntervals + Stack.Upgrade + Stack.Upload + Text.PrettyPrint.Leijen.Extended + System.Process.Log + System.Process.PagerEditor + System.Process.Read + System.Process.Run + System.Terminal + other-modules: + Hackage.Security.Client.Repository.HttpLib.HttpClient + default-language: Haskell2010 + +executable stack + main-is: Main.hs + hs-source-dirs: + src/main + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded + build-depends: + Cabal + , aeson + , annotated-wl-pprint + , ansi-terminal + , async + , attoparsec + , base >=4.9 && <5 + , base64-bytestring + , blaze-builder + , bytestring + , clock + , conduit + , conduit-extra + , containers + , cryptonite + , cryptonite-conduit + , deepseq + , directory + , echo + , exceptions + , extra + , fast-logger + , file-embed + , filelock + , filepath + , fsnotify + , generic-deriving + , hackage-security + , hashable + , hastache + , hpack + , hpc + , http-client + , http-client-tls + , http-conduit + , http-types + , memory + , microlens + , microlens-mtl + , mintty + , monad-logger + , mono-traversable + , mtl + , neat-interpolation + , network-uri + , open-browser + , optparse-applicative + , path + , path-io + , persistent + , persistent-sqlite + , persistent-template + , pretty + , primitive + , process + , project-template + , regex-applicative-text + , resourcet + , retry + , semigroups + , split + , stack + , stm + , store + , store-core + , streaming-commons + , tar + , template-haskell + , temporary + , text + , text-metrics + , th-reify-many + , time + , tls + , transformers + , unicode-transforms + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + , zlib + if os(windows) + cpp-options: -DWINDOWS + build-depends: + Win32 + else + build-depends: + bindings-uname + , pid1 + , unix + build-tools: + hsc2hs + if flag(static) + ld-options: -static -pthread + if !(flag(disable-git-info)) + cpp-options: -DUSE_GIT_INFO + build-depends: + gitrev + , optparse-simple + if flag(hide-dependency-versions) + cpp-options: -DHIDE_DEP_VERSIONS + if flag(supported-build) + cpp-options: -DSUPPORTED_BUILD + other-modules: + Paths_stack + default-language: Haskell2010 + +test-suite stack-integration-test + type: exitcode-stdio-1.0 + main-is: IntegrationSpec.hs + hs-source-dirs: + test/integration + test/integration/lib + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded -rtsopts -with-rtsopts=-N + build-depends: + Cabal + , aeson + , annotated-wl-pprint + , ansi-terminal + , async + , attoparsec + , base >=4.9 && <5 + , base64-bytestring + , blaze-builder + , bytestring + , clock + , conduit + , conduit-extra + , containers + , cryptonite + , cryptonite-conduit + , deepseq + , directory + , echo + , exceptions + , extra + , fast-logger + , file-embed + , filelock + , filepath + , fsnotify + , generic-deriving + , hackage-security + , hashable + , hastache + , hpack + , hpc + , hspec + , http-client + , http-client-tls + , http-conduit + , http-types + , memory + , microlens + , microlens-mtl + , mintty + , monad-logger + , mono-traversable + , mtl + , neat-interpolation + , network-uri + , open-browser + , optparse-applicative + , path + , path-io + , persistent + , persistent-sqlite + , persistent-template + , pretty + , primitive + , process + , project-template + , regex-applicative-text + , resourcet + , retry + , semigroups + , split + , stm + , store + , store-core + , streaming-commons + , tar + , template-haskell + , temporary + , text + , text-metrics + , th-reify-many + , time + , tls + , transformers + , unicode-transforms + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + , zlib + if os(windows) + cpp-options: -DWINDOWS + build-depends: + Win32 + else + build-depends: + bindings-uname + , pid1 + , unix + build-tools: + hsc2hs + if !(flag(integration-tests)) + buildable: False + other-modules: + StackTest + Paths_stack + default-language: Haskell2010 + +test-suite stack-test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: + src/test + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded + build-depends: + Cabal + , QuickCheck + , aeson + , annotated-wl-pprint + , ansi-terminal + , async + , attoparsec + , base >=4.9 && <5 + , base64-bytestring + , blaze-builder + , bytestring + , clock + , conduit + , conduit-extra + , containers + , cryptonite + , cryptonite-conduit + , deepseq + , directory + , echo + , exceptions + , extra + , fast-logger + , file-embed + , filelock + , filepath + , fsnotify + , generic-deriving + , hackage-security + , hashable + , hastache + , hpack + , hpc + , hspec + , http-client + , http-client-tls + , http-conduit + , http-types + , memory + , microlens + , microlens-mtl + , mintty + , monad-logger + , mono-traversable + , mtl + , neat-interpolation + , network-uri + , open-browser + , optparse-applicative + , path + , path-io + , persistent + , persistent-sqlite + , persistent-template + , pretty + , primitive + , process + , project-template + , regex-applicative-text + , resourcet + , retry + , semigroups + , smallcheck + , split + , stack + , stm + , store + , store-core + , streaming-commons + , tar + , template-haskell + , temporary + , text + , text-metrics + , th-reify-many + , time + , tls + , transformers + , unicode-transforms + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + , zlib + if os(windows) + cpp-options: -DWINDOWS + build-depends: + Win32 + else + build-depends: + bindings-uname + , pid1 + , unix + build-tools: + hsc2hs + other-modules: + Network.HTTP.Download.VerifiedSpec + Spec + Stack.ArgsSpec + Stack.Build.ExecuteSpec + Stack.Build.TargetSpec + Stack.ConfigSpec + Stack.DotSpec + Stack.Ghci.PortableFakePaths + Stack.Ghci.ScriptSpec + Stack.GhciSpec + Stack.NixSpec + Stack.PackageDumpSpec + Stack.SolverSpec + Stack.StaticBytesSpec + Stack.StoreSpec + Stack.Untar.UntarSpec + Paths_stack + default-language: Haskell2010 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-8.22 +resolver: lts-9.14 # docker: # enable: true # repo: fpco/stack-full @@ -14,8 +14,18 @@ flags: stack: hide-dependency-versions: true + supported-build: true mintty: win32-2-5: false extra-deps: +- Cabal-2.0.1.0 - mintty-0.1.1 -- unicode-transforms-0.3.2 +- bindings-uname-0.1 +- path-0.6.1 +- path-io-1.3.3 +- extra-1.6 +- hsc2hs-0.68.2 +- hpack-0.20.0 +- unliftio-0.2.0.0 +- ansi-terminal-0.7.1.1 +- ansi-wl-pprint-0.6.8.1 diff --git a/test/integration/IntegrationSpec.hs b/test/integration/IntegrationSpec.hs --- a/test/integration/IntegrationSpec.hs +++ b/test/integration/IntegrationSpec.hs @@ -48,20 +48,20 @@ envOrig <- getEnvironment - withSystemTempDirectory "stack-integration-home" $ \newHome -> do - let env' = Map.toList + withSystemTempDirectory "stackhome" $ \newHome -> do + defaultStackRoot <- getAppUserDataDirectory "stack" + let newStackRoot = newHome takeFileName defaultStackRoot + env' = Map.toList $ Map.insert "STACK_EXE" stack $ Map.insert "HOME" newHome $ Map.insert "APPDATA" newHome + $ Map.insert "STACK_ROOT" newStackRoot $ Map.delete "GHC_PACKAGE_PATH" - $ Map.delete "STACK_ROOT" $ Map.fromList $ map (first (map toUpper)) envOrig - - defaultStackRoot <- getAppUserDataDirectory "stack" - let origStackRoot = fromMaybe defaultStackRoot (lookup "STACK_ROOT" envOrig) + origStackRoot = fromMaybe defaultStackRoot (lookup "STACK_ROOT" envOrig) - hspec $ mapM_ (test runghc env' currDir defaultStackRoot origStackRoot newHome) tests + hspec $ mapM_ (test runghc env' currDir origStackRoot newHome newStackRoot) tests hasTest :: FilePath -> FilePath -> IO Bool hasTest root dir = doesFileExist $ root dir "Main.hs" @@ -69,15 +69,14 @@ test :: FilePath -- ^ runghc -> [(String, String)] -- ^ env -> FilePath -- ^ currdir - -> FilePath -- ^ defaultStackRoot -> FilePath -- ^ origStackRoot -> FilePath -- ^ newHome + -> FilePath -- ^ newStackRoot -> String -> Spec -test runghc env' currDir defaultStackRoot origStackRoot newHome name = it name $ withDir $ \dir -> do +test runghc env' currDir origStackRoot newHome newStackRoot name = it name $ withDir $ \dir -> do newHomeExists <- doesDirectoryExist newHome when newHomeExists (removeDirectoryRecursive newHome) - let newStackRoot = newHome takeFileName defaultStackRoot copyTree toCopyRoot origStackRoot newStackRoot writeFile (newStackRoot "config.yaml") "system-ghc: true" let testDir = currDir "tests" name diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs --- a/test/integration/lib/StackTest.hs +++ b/test/integration/lib/StackTest.hs @@ -5,9 +5,7 @@ import Control.Monad.Trans.Reader import Control.Concurrent import Control.Exception -import Data.List (intercalate) import System.Environment -import System.FilePath import System.Directory import System.IO import System.IO.Error @@ -26,10 +24,13 @@ ec <- run' cmd args unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec +stackExe :: IO String +stackExe = getEnv "STACK_EXE" + stack' :: [String] -> IO ExitCode stack' args = do - stack <- getEnv "STACK_EXE" - run' stack args + stackEnv <- stackExe + run' stackEnv args stack :: [String] -> IO () stack args = do @@ -51,10 +52,10 @@ nextPrompt :: Repl () nextPrompt = do - (ReplConnection _ handle) <- ask - c <- liftIO $ hGetChar handle + (ReplConnection _ inputHandle) <- ask + c <- liftIO $ hGetChar inputHandle if c == '>' - then do _ <- liftIO $ hGetChar handle + then do _ <- liftIO $ hGetChar inputHandle return () else nextPrompt @@ -82,7 +83,7 @@ hSetBuffering rStdout NoBuffering hSetBuffering rStderr NoBuffering - forkIO $ withFile "/tmp/stderr" WriteMode + _ <- forkIO $ withFile "/tmp/stderr" WriteMode $ \err -> forever $ catch (hGetChar rStderr >>= hPutChar err) $ \e -> unless (isEOFError e) $ throw e @@ -91,25 +92,39 @@ repl :: [String] -> Repl () -> IO () repl args action = do - stack <- getEnv "STACK_EXE" - ec <- runRepl stack ("repl":args) action + stackExe' <- stackExe + ec <- runRepl stackExe' ("repl":args) action unless (ec == ExitSuccess) $ return () -- TODO: Understand why the exit code is 1 despite running GHCi tests -- successfully. -- else error $ "Exited with exit code: " ++ show ec +stackStderr :: [String] -> IO (ExitCode, String) +stackStderr args = do + stackExe' <- stackExe + logInfo $ "Running: " ++ stackExe' ++ " " ++ unwords (map showProcessArgDebug args) + (ec, _, err) <- readProcessWithExitCode stackExe' args "" + hPutStr stderr err + return (ec, err) + -- | Run stack with arguments and apply a check to the resulting -- stderr output if the process succeeded. stackCheckStderr :: [String] -> (String -> IO ()) -> IO () stackCheckStderr args check = do - stack <- getEnv "STACK_EXE" - logInfo $ "Running: " ++ stack ++ " " ++ unwords (map showProcessArgDebug args) - (ec, _, err) <- readProcessWithExitCode stack args "" - hPutStr stderr err + (ec, err) <- stackStderr args if ec /= ExitSuccess then error $ "Exited with exit code: " ++ show ec else check err +-- | Same as 'stackCheckStderr', but ensures that the Stack process +-- fails. +stackErrStderr :: [String] -> (String -> IO ()) -> IO () +stackErrStderr args check = do + (ec, err) <- stackStderr args + if ec == ExitSuccess + then error "Stack process succeeded, but it shouldn't" + else check err + doesNotExist :: FilePath -> IO () doesNotExist fp = do logInfo $ "doesNotExist " ++ fp @@ -123,7 +138,7 @@ logInfo $ "doesExist " ++ fp exists <- doesFileOrDirExist fp case exists of - (Right msg) -> return () + (Right _) -> return () (Left _) -> error "No file or directory exists" doesFileOrDirExist :: FilePath -> IO (Either () String) @@ -168,21 +183,37 @@ special _ = False -- | Extension of executables +exeExt :: String exeExt = if isWindows then ".exe" else "" -- | Is the OS Windows? +isWindows :: Bool isWindows = os == "mingw32" -- | Is the OS Alpine Linux? +getIsAlpine :: IO Bool getIsAlpine = doesFileExist "/etc/alpine-release" -- | Is the architecture ARM? +isARM :: Bool isARM = arch == "arm" +-- | Is the OS Mac OS X? +isMacOSX :: Bool +isMacOSX = os == "darwin" + -- | To avoid problems with GHC version mismatch when a new LTS major -- version is released, pass this argument to @stack@ when running in -- a global context. The LTS major version here should match that of -- the main @stack.yaml@ (and ordinarily be the `.0` minor version). -- -- NOTE: currently using lts-8.22 instead of lts-8.0 because the `cyclic-test-deps` integration test is broken with lts-8.0 because a hackage metadata revision invalidated the snapshot (snapshot has `test-framework-quickcheck2-0.3.0.3` and `QuickCheck-2.9.2`, which used to be fine, but now test-framework-quickcheck2 was revised to have a `QuickCheck < 2.8` constraint). +defaultResolverArg :: String defaultResolverArg = "--resolver=lts-8.22" + +-- | Remove a file and ignore any warnings about missing files. +removeFileIgnore :: FilePath -> IO () +removeFileIgnore fp = removeFile fp `catch` \e -> + if isDoesNotExistError e + then return () + else throwIO e