packages feed

stack 1.1.2 → 1.2.0

raw patch · 111 files changed

+5574/−2535 lines, 111 filesdep +annotated-wl-pprintdep +clockdep +lifted-asyncdep ~QuickCheckdep ~bytestringdep ~cryptohashbuild-type:Customsetup-changed

Dependencies added: annotated-wl-pprint, clock, lifted-async, mono-traversable, neat-interpolation, smallcheck, store, th-reify-many, unicode-transforms

Dependency ranges changed: QuickCheck, bytestring, cryptohash, directory, extra, filepath, generic-deriving, hpack, hspec, http-client, http-client-tls, http-conduit, lifted-base, monad-unlift, optparse-applicative, path, process, stack, tar, template-haskell, vector

Files

CONTRIBUTING.md view
@@ -2,43 +2,7 @@  ## Bug Reports -Before reporting a bug, please ensure that you are using the latest release (currently stack-1.1.2).  See the [upgrade instructions](http://docs.haskellstack.org/en/stable/install_and_upgrade/#upgrade) to upgrade.--When reporting a bug, please write in the following format:--> [Any general summary/comments if desired]--> **Steps to reproduce:**--> 1. _Remove directory *blah*._-> 2. _Run command `stack blah`._-> 3. _Edit file blah._-> 3. _Run command `stack blah`._--> **Expected:**--> _What I expected to see and happen._--> **Actual:**--> _What actually happened._->-> Here is the `stack --version` output:->-> ```-> $ stack --version-> Version 0.0.2, Git revision 6a86ee32e5b869a877151f74064572225e1a0398-> ```-> Here is the command I ran **with `--verbose`**:->-> ```-> $ stack <your command here> <args> --verbose-> <output>-> ```--With `--verbose` mode we can see what the tool is doing and when. Without this output it is much more difficult to surmise what's going on with your issue. If the above output is larger than a page, paste it in a private [Gist](https://gist.github.com/) instead.--Include any `.yaml` configuration if relevant.+Please [open an issue](https://github.com/commercialhaskell/stack/issues/new) and use the provided template to include all necessary details.  The more detailed your report, the faster it can be resolved and will ensure it is resolved in the right way. Once your bug has been resolved, the responsible will tag the issue as _Needs confirmation_ and assign the issue back to you. Once you have tested and confirmed that the issue is resolved, close the issue. If you are not a member of the project, you will be asked for confirmation and we will close it.
ChangeLog.md view
@@ -1,5 +1,148 @@ # Changelog +## 1.2.0++Release notes:++* The fix for+  [#2175](https://github.com/commercialhaskell/stack/issues/2175)+  entails that stack must perform a full clone of a large Git repo of+  Hackage meta-information. The total download size is about 200 MB.+  Please be aware of this when upgrading your stack installation.+* On many Un*x systems, stack can now be installed with a simple+  one-liner: `wget -qO- https://get.haskellstack.org/ | sh`+* 64-bit GHC bindists have been built for Linux systems with+  libtinfo6/libncurses6 (such as Fedora 24 and Arch Linux), and `stack setup`+  will detect when to use them.+* Added Ubuntu 16.10 (yakkety) Apt repo.++Major changes:++* Add `stack hoogle` command.+  [#55](https://github.com/commercialhaskell/stack/issues/55)+* Support for absolute file path in `url` field of `setup-info` or `--ghc-bindist`+* Add support for rendering GHCi scripts targeting different GHCi like+  applications+  [#2457](https://github.com/commercialhaskell/stack/pull/2457)++Behavior changes:++* Remove `stack ide start` and `stack ide load-targets` commands.+  [#2178](https://github.com/commercialhaskell/stack/issues/2178)+* Support .buildinfo files in `stack ghci`.+  [#2242](https://github.com/commercialhaskell/stack/pull/2242)+* Support -ferror-spans syntax in GHC error messages.+* Avoid unpacking ghc to `/tmp`+  [#996](https://github.com/commercialhaskell/stack/issues/996)+* The Linux `gmp4` GHC bindist is no longer considered a full-fledged GHC+  variant and can no longer be specified using the `ghc-variant` option,+  and instead is treated more like a slightly different platform.++Other enhancements:++* Use the `store` package for binary serialization of most caches.+* Only require minor version match for Docker stack exe.+  This way, we can make patch releases for version bounds and similar+  build issues without needing to upload new binaries for Docker.+* Stack/Nix: Passes the right ghc derivation as an argument to the `shell.nix` when a+  custom `shell.nix` is used+  See [#2243](https://github.com/commercialhaskell/stack/issues/2243)+* Stack/Nix: Sets `LD_LIBRARY_PATH` so packages using C libs for Template Haskell can work+  (See _e.g._ [this HaskellR issue](https://github.com/tweag/HaskellR/issues/253))+* Parse CLI arguments and configuration files into less permissive types,+  improving error messages for bad inputs.+  [#2267](https://github.com/commercialhaskell/stack/issues/2267)+* Add the ability to explictly specify a gcc executable.+  [#593](https://github.com/commercialhaskell/stack/issues/593)+* Nix: No longer uses LTS mirroring in nixpkgs. Gives to nix-shell a derivation+  like `haskell.compiler.ghc801`+  See [#2259](https://github.com/commercialhaskell/stack/issues/2259)+* Perform some subprocesses during setup concurrently, slightly speeding up most+  commands. [#2346](https://github.com/commercialhaskell/stack/pull/2346)+* `stack setup` no longer unpacks to the system temp dir on posix systems.+  [#996](https://github.com/commercialhaskell/stack/issues/996)+* `stack setup` detects libtinfo6 and ncurses6 and can download alternate GHC+  bindists [#257](https://github.com/commercialhaskell/stack/issues/257)+  [#2302](https://github.com/commercialhaskell/stack/issues/2302).+* `stack setup` detects Linux ARMv7 downloads appropriate GHC bindist+  [#2103](https://github.com/commercialhaskell/stack/issues/2103)+* Custom `stack` binaries list dependency versions in output for `--version`.+  See [#2222](https://github.com/commercialhaskell/stack/issues/2222)+  and [#2450](https://github.com/commercialhaskell/stack/issues/2450).+* Use a pretty printer to output dependency resolution errors.+  [#1912](https://github.com/commercialhaskell/stack/issues/1912)+* Remove the `--os` flag+  [#2227](https://github.com/commercialhaskell/stack/issues/2227)+* Add 'netbase' and 'ca-certificates' as dependency for .deb packages.+  [#2293](https://github.com/commercialhaskell/stack/issues/2293).+* Add `stack ide targets` command.+* Enhance debug logging with subprocess timings.+* Pretty-print YAML parse errors+  [#2374](https://github.com/commercialhaskell/stack/issues/2374)+* Clarify confusing `stack setup` output+  [#2314](https://github.com/commercialhaskell/stack/issues/2314)+* Delete `Stack.Types` multimodule to improve build times+  [#2405](https://github.com/commercialhaskell/stack/issues/2405)+* Remove spurious newlines in build logs+  [#2418](https://github.com/commercialhaskell/stack/issues/2418)+* Interpreter: Provide a way to hide implicit packages+  [#1208](https://github.com/commercialhaskell/stack/issues/1208)+* Check executability in exec lookup+  [#2489](https://github.com/commercialhaskell/stack/issues/2489)++Bug fixes:++* Fix cabal warning about use of a deprecated cabal flag+  [#2350](https://github.com/commercialhaskell/stack/issues/2350)+* Support most executable extensions on Windows+  [#2225](https://github.com/commercialhaskell/stack/issues/2225)+* Detect resolver change in `stack solver`+  [#2252](https://github.com/commercialhaskell/stack/issues/2252)+* Fix a bug in docker image creation where the wrong base image was+  selected+  [#2376](https://github.com/commercialhaskell/stack/issues/2376)+* Ignore special entries when unpacking tarballs+  [#2361](https://github.com/commercialhaskell/stack/issues/2361)+* Fixes src directory pollution of `style.css` and `highlight.js` with GHC 8's+  haddock [#2429](https://github.com/commercialhaskell/stack/issues/2429)+* Handle filepaths with spaces in `stack ghci`+  [#2266](https://github.com/commercialhaskell/stack/issues/2266)+* Apply ghc-options to snapshot packages+  [#2289](https://github.com/commercialhaskell/stack/issues/2289)+* stack sdist: Fix timestamp in tarball+  [#2394](https://github.com/commercialhaskell/stack/pull/2394)+* Allow global Stack arguments with a script+  [#2316](https://github.com/commercialhaskell/stack/issues/2316)+* Inconsistency between ToJSON and FromJSON instances of PackageLocation+  [#2412](https://github.com/commercialhaskell/stack/pull/2412)+* Perform Unicode normalization on filepaths+  [#1810](https://github.com/commercialhaskell/stack/issues/1810)+* Solver: always keep ghc wired-in as hard constraints+  [#2453](https://github.com/commercialhaskell/stack/issues/2453)+* Support OpenBSD's tar where possible, require GNU tar for xz support+  [#2283](https://github.com/commercialhaskell/stack/issues/2283)+* Fix using --coverage with Cabal-1.24+  [#2424](https://github.com/commercialhaskell/stack/issues/2424)+* When marking exe installed, remove old version+  [#2373](https://github.com/commercialhaskell/stack/issues/2373)+* Stop truncating all-cabal-hashes git repo+  [#2175](https://github.com/commercialhaskell/stack/issues/2175)+* Handle non-ASCII filenames on Windows+  [#2491](https://github.com/commercialhaskell/stack/issues/2491)+* Avoid using multiple versions of a package in script interpreter+  by passing package-id to ghc/runghc+  [#1957](https://github.com/commercialhaskell/stack/issues/1957)+* Only pre-load compiler version when using nix integration+  [#2459](https://github.com/commercialhaskell/stack/issues/2459)+* Solver: parse cabal errors also on Windows+  [#2502](https://github.com/commercialhaskell/stack/issues/2502)+* Allow exec and ghci commands in interpreter mode.+  Scripts can now automatically open in the repl by using `exec ghci`+  instead of `runghc` in the shebang command.+  [#2510](https://github.com/commercialhaskell/stack/issues/2510)+* Now consider a package to be dirty when an extra-source-file is changed.+  See [#2040](https://github.com/commercialhaskell/stack/issues/2040)+ ## 1.1.2  Release notes:
Setup.hs view
@@ -1,2 +1,55 @@-import Distribution.Simple-main = defaultMain+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+module Main (main) where++import Data.List ( nub, sortBy )+import Data.Ord ( comparing )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), Executable(..) )+import Distribution.InstalledPackageInfo (sourcePackageId, installedPackageId)+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+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.Verbosity ( Verbosity )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  }++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  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"+        , ""+        , "deps :: [String]"+        , "deps = " ++ (show $ formatdeps (transDeps libcfg clbi))+        ]+  where+    formatdeps = map formatone . sortBy (comparing unPackageName')+    formatone p = unPackageName' p ++ "-" ++ showVersion (packageVersion p)+    unPackageName' p = case packageName p of PackageName n -> n+    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+        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
doc/CONTRIBUTING.md view
@@ -2,43 +2,7 @@  ## Bug Reports -Before reporting a bug, please ensure that you are using the latest release (currently stack-1.1.2).  See the [upgrade instructions](http://docs.haskellstack.org/en/stable/install_and_upgrade/#upgrade) to upgrade.--When reporting a bug, please write in the following format:--> [Any general summary/comments if desired]--> **Steps to reproduce:**--> 1. _Remove directory *blah*._-> 2. _Run command `stack blah`._-> 3. _Edit file blah._-> 3. _Run command `stack blah`._--> **Expected:**--> _What I expected to see and happen._--> **Actual:**--> _What actually happened._->-> Here is the `stack --version` output:->-> ```-> $ stack --version-> Version 0.0.2, Git revision 6a86ee32e5b869a877151f74064572225e1a0398-> ```-> Here is the command I ran **with `--verbose`**:->-> ```-> $ stack <your command here> <args> --verbose-> <output>-> ```--With `--verbose` mode we can see what the tool is doing and when. Without this output it is much more difficult to surmise what's going on with your issue. If the above output is larger than a page, paste it in a private [Gist](https://gist.github.com/) instead.--Include any `.yaml` configuration if relevant.+Please [open an issue](https://github.com/commercialhaskell/stack/issues/new) and use the provided template to include all necessary details.  The more detailed your report, the faster it can be resolved and will ensure it is resolved in the right way. Once your bug has been resolved, the responsible will tag the issue as _Needs confirmation_ and assign the issue back to you. Once you have tested and confirmed that the issue is resolved, close the issue. If you are not a member of the project, you will be asked for confirmation and we will close it.
doc/ChangeLog.md view
@@ -1,5 +1,148 @@ # Changelog +## 1.2.0++Release notes:++* The fix for+  [#2175](https://github.com/commercialhaskell/stack/issues/2175)+  entails that stack must perform a full clone of a large Git repo of+  Hackage meta-information. The total download size is about 200 MB.+  Please be aware of this when upgrading your stack installation.+* On many Un*x systems, stack can now be installed with a simple+  one-liner: `wget -qO- https://get.haskellstack.org/ | sh`+* 64-bit GHC bindists have been built for Linux systems with+  libtinfo6/libncurses6 (such as Fedora 24 and Arch Linux), and `stack setup`+  will detect when to use them.+* Added Ubuntu 16.10 (yakkety) Apt repo.++Major changes:++* Add `stack hoogle` command.+  [#55](https://github.com/commercialhaskell/stack/issues/55)+* Support for absolute file path in `url` field of `setup-info` or `--ghc-bindist`+* Add support for rendering GHCi scripts targeting different GHCi like+  applications+  [#2457](https://github.com/commercialhaskell/stack/pull/2457)++Behavior changes:++* Remove `stack ide start` and `stack ide load-targets` commands.+  [#2178](https://github.com/commercialhaskell/stack/issues/2178)+* Support .buildinfo files in `stack ghci`.+  [#2242](https://github.com/commercialhaskell/stack/pull/2242)+* Support -ferror-spans syntax in GHC error messages.+* Avoid unpacking ghc to `/tmp`+  [#996](https://github.com/commercialhaskell/stack/issues/996)+* The Linux `gmp4` GHC bindist is no longer considered a full-fledged GHC+  variant and can no longer be specified using the `ghc-variant` option,+  and instead is treated more like a slightly different platform.++Other enhancements:++* Use the `store` package for binary serialization of most caches.+* Only require minor version match for Docker stack exe.+  This way, we can make patch releases for version bounds and similar+  build issues without needing to upload new binaries for Docker.+* Stack/Nix: Passes the right ghc derivation as an argument to the `shell.nix` when a+  custom `shell.nix` is used+  See [#2243](https://github.com/commercialhaskell/stack/issues/2243)+* Stack/Nix: Sets `LD_LIBRARY_PATH` so packages using C libs for Template Haskell can work+  (See _e.g._ [this HaskellR issue](https://github.com/tweag/HaskellR/issues/253))+* Parse CLI arguments and configuration files into less permissive types,+  improving error messages for bad inputs.+  [#2267](https://github.com/commercialhaskell/stack/issues/2267)+* Add the ability to explictly specify a gcc executable.+  [#593](https://github.com/commercialhaskell/stack/issues/593)+* Nix: No longer uses LTS mirroring in nixpkgs. Gives to nix-shell a derivation+  like `haskell.compiler.ghc801`+  See [#2259](https://github.com/commercialhaskell/stack/issues/2259)+* Perform some subprocesses during setup concurrently, slightly speeding up most+  commands. [#2346](https://github.com/commercialhaskell/stack/pull/2346)+* `stack setup` no longer unpacks to the system temp dir on posix systems.+  [#996](https://github.com/commercialhaskell/stack/issues/996)+* `stack setup` detects libtinfo6 and ncurses6 and can download alternate GHC+  bindists [#257](https://github.com/commercialhaskell/stack/issues/257)+  [#2302](https://github.com/commercialhaskell/stack/issues/2302).+* `stack setup` detects Linux ARMv7 downloads appropriate GHC bindist+  [#2103](https://github.com/commercialhaskell/stack/issues/2103)+* Custom `stack` binaries list dependency versions in output for `--version`.+  See [#2222](https://github.com/commercialhaskell/stack/issues/2222)+  and [#2450](https://github.com/commercialhaskell/stack/issues/2450).+* Use a pretty printer to output dependency resolution errors.+  [#1912](https://github.com/commercialhaskell/stack/issues/1912)+* Remove the `--os` flag+  [#2227](https://github.com/commercialhaskell/stack/issues/2227)+* Add 'netbase' and 'ca-certificates' as dependency for .deb packages.+  [#2293](https://github.com/commercialhaskell/stack/issues/2293).+* Add `stack ide targets` command.+* Enhance debug logging with subprocess timings.+* Pretty-print YAML parse errors+  [#2374](https://github.com/commercialhaskell/stack/issues/2374)+* Clarify confusing `stack setup` output+  [#2314](https://github.com/commercialhaskell/stack/issues/2314)+* Delete `Stack.Types` multimodule to improve build times+  [#2405](https://github.com/commercialhaskell/stack/issues/2405)+* Remove spurious newlines in build logs+  [#2418](https://github.com/commercialhaskell/stack/issues/2418)+* Interpreter: Provide a way to hide implicit packages+  [#1208](https://github.com/commercialhaskell/stack/issues/1208)+* Check executability in exec lookup+  [#2489](https://github.com/commercialhaskell/stack/issues/2489)++Bug fixes:++* Fix cabal warning about use of a deprecated cabal flag+  [#2350](https://github.com/commercialhaskell/stack/issues/2350)+* Support most executable extensions on Windows+  [#2225](https://github.com/commercialhaskell/stack/issues/2225)+* Detect resolver change in `stack solver`+  [#2252](https://github.com/commercialhaskell/stack/issues/2252)+* Fix a bug in docker image creation where the wrong base image was+  selected+  [#2376](https://github.com/commercialhaskell/stack/issues/2376)+* Ignore special entries when unpacking tarballs+  [#2361](https://github.com/commercialhaskell/stack/issues/2361)+* Fixes src directory pollution of `style.css` and `highlight.js` with GHC 8's+  haddock [#2429](https://github.com/commercialhaskell/stack/issues/2429)+* Handle filepaths with spaces in `stack ghci`+  [#2266](https://github.com/commercialhaskell/stack/issues/2266)+* Apply ghc-options to snapshot packages+  [#2289](https://github.com/commercialhaskell/stack/issues/2289)+* stack sdist: Fix timestamp in tarball+  [#2394](https://github.com/commercialhaskell/stack/pull/2394)+* Allow global Stack arguments with a script+  [#2316](https://github.com/commercialhaskell/stack/issues/2316)+* Inconsistency between ToJSON and FromJSON instances of PackageLocation+  [#2412](https://github.com/commercialhaskell/stack/pull/2412)+* Perform Unicode normalization on filepaths+  [#1810](https://github.com/commercialhaskell/stack/issues/1810)+* Solver: always keep ghc wired-in as hard constraints+  [#2453](https://github.com/commercialhaskell/stack/issues/2453)+* Support OpenBSD's tar where possible, require GNU tar for xz support+  [#2283](https://github.com/commercialhaskell/stack/issues/2283)+* Fix using --coverage with Cabal-1.24+  [#2424](https://github.com/commercialhaskell/stack/issues/2424)+* When marking exe installed, remove old version+  [#2373](https://github.com/commercialhaskell/stack/issues/2373)+* Stop truncating all-cabal-hashes git repo+  [#2175](https://github.com/commercialhaskell/stack/issues/2175)+* Handle non-ASCII filenames on Windows+  [#2491](https://github.com/commercialhaskell/stack/issues/2491)+* Avoid using multiple versions of a package in script interpreter+  by passing package-id to ghc/runghc+  [#1957](https://github.com/commercialhaskell/stack/issues/1957)+* Only pre-load compiler version when using nix integration+  [#2459](https://github.com/commercialhaskell/stack/issues/2459)+* Solver: parse cabal errors also on Windows+  [#2502](https://github.com/commercialhaskell/stack/issues/2502)+* Allow exec and ghci commands in interpreter mode.+  Scripts can now automatically open in the repl by using `exec ghci`+  instead of `runghc` in the shebang command.+  [#2510](https://github.com/commercialhaskell/stack/issues/2510)+* Now consider a package to be dirty when an extra-source-file is changed.+  See [#2040](https://github.com/commercialhaskell/stack/issues/2040)+ ## 1.1.2  Release notes:
doc/GUIDE.md view
@@ -62,7 +62,7 @@ michael@d30748af6d3d:~$ stack -bash: stack: command not found # Get the signing key for the package repo-michael@d30748af6d3d:~$ wget -q -O- https://s3.amazonaws.com/download.fpcomplete.com/ubuntu/fpco.key | sudo apt-key add -+michael@d30748af6d3d:~$ wget -q -O- https://download.fpcomplete.com/ubuntu/fpco.key | sudo apt-key add - OK michael@d30748af6d3d:~$ echo 'deb http://download.fpcomplete.com/ubuntu/trusty stable main'|sudo tee /etc/apt/sources.list.d/fpco.list deb http://download.fpcomplete.com/ubuntu/trusty stable main@@ -142,7 +142,7 @@ michael@d30748af6d3d:~/helloworld$ stack setup Downloaded ghc-7.10.2. Installed GHC.-stack will use a locally installed GHC+stack will use a sandboxed GHC it installed For more information on paths, see 'stack path' and 'stack exec env' To use this GHC and packages outside of a project, consider using: stack ghc, stack ghci, stack runghc, or stack exec@@ -325,20 +325,20 @@  ``` michael@d30748af6d3d:~/helloworld$ stack setup-stack will use a locally installed GHC+stack will use a sandboxed GHC it installed For more information on paths, see 'stack path' and 'stack exec env' To use this GHC and packages outside of a project, consider using: stack ghc, stack ghci, stack runghc, or stack exec ```  Thankfully, the command is smart enough to know not to perform an installation-twice. `setup` will either use the first GHC it finds on your PATH, or a locally-installed version. As the command output above indicates, you can use `stack+twice. `setup` will either use the first GHC it finds on your PATH, or a sandboxed+version after installing it. As the command output above indicates, you can use `stack path` for quite a bit of path information (which we'll play with more later). For now, we'll just look at where GHC is installed:  ```-michael@d30748af6d3d:~/helloworld$ stack exec which ghc+michael@d30748af6d3d:~/helloworld$ stack exec -- which ghc /home/michael/.stack/programs/x86_64-linux/ghc-7.10.2/bin/ghc ``` @@ -441,6 +441,49 @@ (helloworld). At no point did we need to ask stack to build dependencies — it does so automatically. +### Listing Dependencies++Let's have stack add a few more dependencies to our project. First, we'll include two new packages in the+`build-depends` section for our library in our `helloworld.cabal`:++```+library+  hs-source-dirs:      src+  exposed-modules:     Lib+  build-depends:       base >= 4.7 && < 5+                     , text+                     -- a couple more dependencies...+                     , filepath+                     , containers+```++After adding these two dependencies, we can again run `stack build` to have them installed:++```+michael@d30748af6d3d:~/helloworld$ stack build+helloworld-0.1.0.0: unregistering (dependencies changed)+helloworld-0.1.0.0: configure+Configuring helloworld-0.1.0.0...+...+```++Finally, to find out which versions of these libraries stack installed, we can ask stack to `list-dependencies`:++```+michael@d30748af6d3d:~/helloworld$ stack list-dependencies+array 0.5.1.0+base 4.8.2.0+binary 0.7.5.0+bytestring 0.10.6.0+containers 0.5.6.2+deepseq 1.4.1.1+filepath 1.4.0.0+ghc-prim 0.4.0.0+helloworld 0.1.0.0+integer-gmp 1.0.0.0+text 1.2.2.1+```+ ### extra-deps  Let's try a more off-the-beaten-track package: the joke@@ -1086,7 +1129,7 @@ which contains the libraries and executables specified in the snapshot itself. Finally, GHC itself ships with a number of libraries and executables, which forms the *global* database. To get a quick idea of this, we can look at the-output of the `stack exec ghc-pkg list` command in our helloworld project:+output of the `stack exec -- ghc-pkg list` command in our helloworld project:  ``` /home/michael/.stack/programs/x86_64-linux/ghc-7.10.2/lib/ghc-7.10.2/package.conf.d@@ -1515,7 +1558,7 @@  In addition, `stack path` accepts command line arguments to state which of these keys you're interested in, which can be convenient for scripting. As a-simple example, let's find out which versions of GHC are installed locally:+simple example, let's find out the sandboxed versions of GHC that stack installed:  ``` michael@d30748af6d3d:~/wai$ ls $(stack path --programs)/*.installed@@ -1642,6 +1685,13 @@ If you're on Windows: you can run `stack turtle.hs` instead of `./turtle.hs`. The shebang line is not required in that case. +### Stack configuration for scripts++If the current working directory is inside a project then that project's stack+configuration is effective when running the script. Otherwise the script uses+the global project configuration specified in+`~/.stack/global-project/stack.yaml`.+ ### Specifying interpreter options  The stack interpreter options comment must specify a single valid stack command@@ -1652,8 +1702,10 @@ column of the line.  When many options are needed a block style comment may be more convenient to-split the command on multiple lines for better readability. Here is an example-of a multi line block comment:+split the command on multiple lines for better readability. You can also+specify ghc options the same way as you would on command line i.e. by+separating the stack options and ghc options with a `--`. Here is an example of+a multi line block comment with ghc options:  ```   #!/usr/bin/env stack@@ -1662,8 +1714,44 @@     --install-ghc     runghc     --package turtle+    --+    -hide-all-packages   -} ```++### Writing independent and reliable scripts++Independent means that the script is independent of any prior deployment+specific configuration. If required, the script will install everything it+needs automatically on any machine that it runs on. To make a script always+work irrespective of any specific environment configuration you can do the+following:++1. Use the `--install-ghc` option to install the compiler automatically+2. Explicitly specify all packages required by the script using the+`--package` option. Use `-hide-all-packages` ghc option to force+explicit specification of all packages.++Reliable means the script will use exactly the same version of all packages+every time it runs so that the script does not break by accidentally using+incompatible package versions. To achieve that use an explicit `--resolver`+stack option.++Here is an interpreter comment for a completely self-contained and reproducible+version of our toy example:+```+  #!/usr/bin/env stack+  {- stack+    --resolver lts-3.2+    --install-ghc+    runghc+    --package base+    --package turtle+    --+    -hide-all-packages+  -}+```+ ## Finding project configs, and the implicit global  Whenever you run something with stack, it needs a stack.yaml project file. The@@ -1826,9 +1914,16 @@ Wrote project config to: /home/michael/my-yesod-project/stack.yaml ``` -To add more templates, see [the stack-templates-repository](https://github.com/commercialhaskell/stack-templates#readme).+Alternatively you can use your own templates by specifying the path: +```+stack new project ~/location/of/your/template.hsfiles+```++As a starting point you can use [the "simple" template](https://github.com/commercialhaskell/stack-templates/blob/master/simple.hsfiles).+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  stack has a work-in-progress suite of editor integrations, to do things like@@ -1897,6 +1992,9 @@   - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7     compiler: ": #GHC 7.10.3"     addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}+  - env: BUILD=cabal GHCVER=8.0.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7+    compiler: ": #GHC 8.0.1"+    addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}    # Build with the newest GHC and cabal-install. This is an accepted failure,   # see below.@@ -1918,7 +2016,7 @@     compiler: ": #stack 7.10.2"     addons: {apt: {packages: [ghc-7.10.2], sources: [hvr-ghc]}} -  - env: BUILD=stack ARGS="--resolver lts-5"+  - env: BUILD=stack ARGS="--resolver lts-6"     compiler: ": #stack 7.10.3"     addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} @@ -1940,7 +2038,7 @@     compiler: ": #stack 7.10.2 osx"     os: osx -  - env: BUILD=stack ARGS="--resolver lts-5"+  - env: BUILD=stack ARGS="--resolver lts-6"     compiler: ": #stack 7.10.3 osx"     os: osx @@ -2017,8 +2115,13 @@         cd $dir         cabal check || [ "$CABALVER" == "1.16" ]         cabal sdist-        SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \-          (cd dist && cabal install --force-reinstalls "$SRC_TGZ")+        PKGVER=$(cabal info . | awk '{print $2;exit}')+        SRC_TGZ=$PKGVER.tar.gz+        cd dist+        tar zxfv "$SRC_TGZ"+        cd "$PKGVER"+        cabal configure --enable-tests+        cabal build         cd $ORIGDIR       done       ;;@@ -2166,24 +2269,53 @@  ## Debugging -The following command installs with profiling enabled:+To profile a component of the current project, simply pass the `--profile`+flag to `stack`. The `--profile` flag turns on the `--enable-library-profiling`+and `--enable-executable-profiling` Cabal options _and_ passes the `+RTS -p`+runtime options to any testsuites and benchmarks. -`stack install --enable-executable-profiling --enable-library-profiling---ghc-options="-rtsopts"`+For example the following command will build the `my-tests` testsuite with+profiling options and create a `my-tests.prof` file in the current directory+as a result of the test run. -This command will allow you to use various tools to profile the time,-allocation, heap, and more of a program. The `-prof` GHC option is unnecessary-and will result in a warning. Additional compilation options can be added to-`--ghc-options` if needed. To see a general overview of the time and allocation-of a program called `main` compiled with the above command, you can run+    stack test --profile my-tests -`./main +RTS -p`+The `my-tests.prof` file now contains time and allocation info for the test run. -to generate a `main.prof` file containing the requested profiling information.-Alternatively, you can use `stack exec main -- +RTS -p`, where `--` allows you-to specify parameters for `main` executable (without `--` the `stack`-executable would use those parameters instead).+To create a profiling report for an executable, e.g. `my-exe`, you can+run +     stack exec -- my-exe +RTS -p++For more fine-grained control of compilation options there are the+`--library-profiling` and `--executable-profiling` flags which will turn on the+`--enable-library-profiling` and `--enable-executable-profiling` Cabal+options respectively.+Custom GHC options can be passed in with `--ghc-options "more options here"`.++To enable compilation with profiling options by default you can add the+following snippet to your `stack.yaml` or `~/.stack/config.yaml`:++```+build:+  library-profiling: true+  executable-profiling: true+```++### Tracing++To generate a backtrace in case of exceptions during a test or benchmarks run,+use the `--trace` flag. Like `--profile` this compiles with profiling options,+but adds the `+RTS -xc` runtime option.++### DWARF++`stack` currently doesn't support debugging and profiling with+[DWARF information](https://ghc.haskell.org/trac/ghc/wiki/DWARF)+as it strips executables automatically. This may change in the future (see+[#877](https://github.com/commercialhaskell/stack/issues/877)).++### 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),
doc/MAINTAINER_GUIDE.md view
@@ -37,6 +37,7 @@           with new version         * Look for any links to "latest" documentation, replace with version tag         * Ensure all documentation pages listed in `mkdocs.yaml`+    * Update the ISSUE_TEMPLATE.md to point at the new version.     * Check that any new Linux distribution versions added to       `etc/scripts/release.hs` and `etc/scripts/vagrant-releases.sh`         * [Ubuntu](https://wiki.ubuntu.com/Releases)@@ -95,10 +96,6 @@   [stack-setup-2.yaml](https://github.com/fpco/stackage-content/blob/master/stack/stack-setup-2.yaml),   and add the new linux64 stack bindist -* Activate version for new release tag on-  [readthedocs.org](https://readthedocs.org/projects/stack/versions/), and-  ensure that stable documentation has updated- * Submit a PR for the   [haskell-stack Homebrew formula](https://github.com/Homebrew/homebrew-core/blob/master/Formula/haskell-stack.rb)       * Be sure to update the SHA sum@@ -106,7 +103,7 @@  * [Flag the Arch Linux package as out-of-date](https://www.archlinux.org/packages/community/x86_64/stack/flag/) -* Push signed Git tag, matching Github release tag name, e.g.: `git tag -u+* Push signed Git tag, matching Github release tag name, e.g.: `git tag -d vX.Y.Z && git tag -u   0x575159689BEFB442 vX.Y.Z && git push origin vX.Y.Z`  * Reset the `release` branch to the released commit, e.g.: `git checkout release@@ -116,6 +113,10 @@  * Delete the RC branch (locally and on origin) +* Activate version for new release tag on+  [readthedocs.org](https://readthedocs.org/projects/stack/versions/), and+  ensure that stable documentation has updated+ * Upload haddocks to Hackage: `etc/scripts/upload-haddocks.sh`  * Merge any changes made in the RC/release/stable branches to master.@@ -191,5 +192,65 @@         git config --global user.email manny@fpcomplete.com         git config --global user.name "Emanuel Borsboom"         git config --global push.default simple+        git config --global core.autocrlf true         git clone git@github.com:commercialhaskell/stack.git         git clone git@github.com:borsboom/stack-installer.git++## Adding a new GHC version++  * Push new tag to our fork:++        git clone git@github.com:commercialhaskell/ghc.git+        cd ghc+        git remote add upstream git@github.com:ghc/ghc.git+        git fetch upstream+        git push origin ghc-X.Y.Z-release++  * [Publish a new Github release](https://github.com/commercialhaskell/ghc/releases/new)+    with tag `ghc-X.Y.Z-release` and same name.++  * Down all the relevant GHC bindists from https://www.haskell.org/ghc/download_ghc_X_Y_Z and upload them to the just-created Github release (see+    [stack-setup-2.yaml](https://github.com/fpco/stackage-content/blob/master/stack/stack-setup-2.yaml)+    for the ones we used in the last GHC release).++    In the case of OS X, repackage the `.xz` bindist as a `.bz2`, since OS X does+    not include `xz` by default or provide an easy way to install it.++  * Build any additional required bindists (see below for instructions)++      * libtinfo6 (etc/vagrant/fedora24-x86_64)++  * [Edit stack-setup-2.yaml](https://github.com/fpco/stackage-content/edit/master/stack/stack-setup-2.yaml)+    and add the new bindists, pointing to the Github release version. Be sure to+    update the `content-length` and `sha1` values.++### Building GHC++Set the `GHC_VERSION` environment variable to the version to build.++For GHC >= 7.10.2, run (from [here](https://ghc.haskell.org/trac/ghc/wiki/Newcomers)):++    git config --global url."git://github.com/ghc/packages-".insteadOf git://github.com/ghc/packages/ && \+    git clone -b ghc-${GHC_VERSION}-release --recursive git://github.com/ghc/ghc ghc-${GHC_VERSION} && \+    cd ghc-${GHC_VERSION}/ && \+    cp mk/build.mk.sample mk/build.mk && \+    sed -i 's/^#BuildFlavour *= *perf$/BuildFlavour = perf/' mk/build.mk && \+    ./boot && \+    ./configure --enable-tarballs-autodownload && \+    sed -i 's/^TAR_COMP *= *bzip2$/TAR_COMP = xz/' mk/config.mk && \+    make -j$(cat /proc/cpuinfo|grep processor|wc -l) && \+    make binary-dist++GHC 7.8.4 is slightly different:++    git config --global url."git://github.com/ghc/packages-".insteadOf git://github.com/ghc/packages/ && \+    git clone -b ghc-${GHC_VERSION}-release --recursive git://github.com/ghc/ghc ghc-${GHC_VERSION} && \+    cd ghc-${GHC_VERSION}/ && \+    ./sync-all --extra --nofib -r git://git.haskell.org get -b ghc-7.8 && \+    cp mk/build.mk.sample mk/build.mk && \+    sed -i 's/^#BuildFlavour *= *perf$/BuildFlavour = perf/' mk/build.mk && \+    perl boot && \+    ./configure && \+    sed -i 's/^TAR_COMP *= *bzip2$/TAR_COMP = xz/' mk/config.mk && \+    make -j$(cat /proc/cpuinfo|grep processor|wc -l) && \+    make binary-dist
doc/README.md view
@@ -3,7 +3,7 @@ Stack is a cross-platform program for developing Haskell projects. It is aimed at Haskellers both new and experienced. -<img src="http://i.imgur.com/WW69oTj.gif" width="50%" align="right">+<img src="https://i.imgur.com/WW69oTj.gif" width="50%" align="right">  It features: @@ -15,8 +15,17 @@  #### How to install -Downloads are available by operating system:+For many Un*x operating systems, all you need to do is run: +    curl -sSL https://get.haskellstack.org/ | sh++or:++    wget -qO- https://get.haskellstack.org/ | sh++For detailed instructions and downloads, instructions are available by+operating system/distribution:+ * [Windows](install_and_upgrade.md#windows) * [Mac OS X](install_and_upgrade.md#mac-os-x) * [Ubuntu](install_and_upgrade.md#ubuntu)@@ -30,11 +39,6 @@ * [FreeBSD](install_and_upgrade.md#freebsd)  [Upgrade instructions](install_and_upgrade.md#upgrade)--Note: if you are using cabal-install to install stack, you may need to pass a-constraint to work around a-[Cabal issue](https://github.com/haskell/cabal/issues/2759): `cabal install---constraint 'mono-traversable >= 0.9' stack`.  #### Quick Start Guide
doc/build_command.md view
@@ -2,10 +2,11 @@  ## Overview -The primary command you use in stack is build. This page describes the details-of build's command line interface. The goal of the interface is to do the right-thing for simple input, and allow a lot of flexibility for more complicated-goals.+The primary command you use in stack is build. This page describes the build+command's interface. The goal of the interface is to do the right thing for+simple input, and allow a lot of flexibility for more complicated goals. See the+[build command section of the user guide](GUIDE.md#the-build-command) for info+beyond the CLI aspects of the build command.  ## Synonyms @@ -79,15 +80,39 @@ packages in the current directory or deeper, you can pass in `.`, e.g. `stack build .`. -### Examples+To get a list of the available targets in your project, use `stack ide targets`. -FIXME: what examples would be helpful? Need feedback on what's confusing above+## Controlling what gets built -## Dependencies+Stack will automatically build the necessary+dependencies. See the+[build command section of the user guide](GUIDE.md#the-build-command) for+details of how these dependencies get specified. -stack will always automatically build all dependencies necessary for its targets.+In addition to specifying targets, you can also control what gets built with the+following flags: -## Other flags+* `--haddock`, to build documentation.  This may cause a lot of packages to get+  re-built, so that the documentation links work.++* `--force-dirty`, to force rebuild of packages even when it doesn't seem+  necessary based on file dirtiness.++* `--reconfigure`, to force reconfiguration even when it doesn't seem necessary+  based on file dirtiness. This is sometimes useful with custom Setup.hs files,+  in particular when they depend on external data files.++* `--dry-run`, to build nothing and output information about the build plan.++* `--only-dependencies`, to skip building the targets.++* `--only-snapshot`, to only build snapshot dependencies, which are cached and+  shared with other projects.++* `--keep-going`, to continue building packages even after some build step+  fails. The packages which depend upon the failed build won't get built.++## Flags  There are a number of other flags accepted by `stack build`. Instead of listing all of them, please use `stack build --help`. Some particularly convenient ones
doc/docker_integration.md view
@@ -16,6 +16,51 @@ blog post for more information about the motivation and implementation of stack's Docker support. +Prerequisites+-------------------------------------------------------------------------------++### Supported operating systems++**Linux 64-bit**: Docker use requires machine (virtual or metal) running a Linux+distribution+[that Docker supports](https://docs.docker.com/installation/#installation), with+a 64-bit kernel. If you do not already have one, we suggest Ubuntu 14.04+("trusty") since this is what we test with.++**Mac OS X**: [Docker for Mac](https://docs.docker.com/docker-for-mac/) is the+supported way to use Docker integration on OS X (the older Docker Machine+(boot2docker) approach to using Docker on OS X is not supported due to issues+with host volume mounting that make Stack nearly unusable for anything but the+most trivial projects).++Other Un*xen are not officially supported but there are ways to get them working.+See [#194](https://github.com/commercialhaskell/stack/issues/194) for details+and workarounds.++**Windows does not work at all** (see+[#2421](https://github.com/commercialhaskell/stack/issues/2421)).++### Docker++Install the latest version of Docker by following the+[instructions for your operating system](http://docs.docker.com/installation/).++The Docker client should be able to connect to the Docker daemon as a non-root+user. For example (from+[here](http://docs.docker.com/installation/ubuntulinux/#ubuntu-raring-1304-and-saucy-1310-64-bit)):++    # Add the connected user "${USER}" to the docker group.+    # Change the user name to match your preferred user.+    sudo gpasswd -a ${USER} docker++    # Restart the Docker daemon.+    sudo service docker restart++You will now need to log out and log in again for the group addition+to take effect.++Note the above has security implications.  See [security](#security) for more.+ Usage ------------------------------------------------------------------------------- @@ -30,7 +75,8 @@     docker:         enable: true -See [configuration](#configuration) for additional options.+See [configuration](#configuration) for additional options. You can enable it on+the command-line using `stack --docker`.  ### Use stack as normal @@ -145,7 +191,7 @@       # If true, the container will be run "detached" (in the background).  Refer       # to the Docker users guide for information about how to manage containers.       # This option would rarely make sense in the configuration file, but can be-      # useful on the command-line.  When true, implies `persist`.`+      # useful on the command-line.  When true, implies `persist`.       detach: false        # If true, the container will not be deleted after it terminates.  Refer to@@ -172,7 +218,7 @@        # Environment variables to set in the container.  Environment variables       # are not automatically inherited from the host, so if you need any specific-      # variables, use the '--docker-env` command-line argument version of this to+      # variables, use the `--docker-env` command-line argument version of this to       # pass them in.  (default none)       env:         - "FOO=BAR"@@ -238,43 +284,6 @@ used with Stack's Docker integration. For example, the [official Haskell image repository](https://hub.docker.com/_/haskell/) works. See [Custom images](#custom-images) for more details.--Prerequisites----------------------------------------------------------------------------------### Linux 64-bit--Docker use requires machine (virtual or metal) running a Linux distribution-[that Docker supports](https://docs.docker.com/installation/#installation), with-a 64-bit kernel. If you do not already have one, we suggest Ubuntu 14.04-("trusty") since this is what we test with.--While Docker does support non-Linux operating systems through the `boot2docker`-VM, there are issues with host volume mounting that prevent stack from being-usable in this configuration. See-[#194](https://github.com/commercialhaskell/stack/issues/194) for details and-workarounds.--### Docker--Install the latest version of Docker by following the-[instructions for your operating system](http://docs.docker.com/installation/).--The Docker client should be able to connect to the Docker daemon as a non-root-user. For example (from-[here](http://docs.docker.com/installation/ubuntulinux/#ubuntu-raring-1304-and-saucy-1310-64-bit)):--    # Add the connected user "${USER}" to the docker group.-    # Change the user name to match your preferred user.-    sudo gpasswd -a ${USER} docker--    # Restart the Docker daemon.-    sudo service docker restart--You will now need to log out and log in again for the group addition-to take effect.--Note the above has security implications.  See [security](#security) for more.  Security -------------------------------------------------------------------------------
doc/faq.md view
@@ -246,6 +246,7 @@ Stack makes use of a temporary directory for some commands (/tmp by default on linux). If there is not enough free space in this directory, stack may fail (see issue [#429](https://github.com/commercialhaskell/stack/issues/429) ). For instance `stack setup` with a GHC installation requires roughly 1GB free.  A custom temporary directory can be forced:+ * on Linux by setting the environment variable TMPDIR (eg `$ TMPDIR=path-to-tmp stack setup`) * on Windows by setting one of the environment variable (given in priority order), TMP, TEMP, USERPROFILE @@ -256,14 +257,26 @@ you, please _manually_ set TMPDIR before launching Stack to some directory on the disk. -## stack sometimes rebuilds based on flag changes when I wouldn't expect it to. How come?+## Why doesn't stack rebuild my project when I specify `--ghc-options` on the command line? -stack tries to give you reproducibility whenever possible. In some cases, this means that you get a recompile when one may not seem necessary. The most common example is running something like this in a multi-package project:+Because GHC options often only affect optimization levels and warning behavior, stack doesn't recompile+when it detects an option change by default. This behavior can be changed though by setting the+[`rebuild-ghc-options` option](yaml_configuration.md#rebuild-ghc-options) to `true`. -    stack build --ghc-options -O0 && stack build --ghc-options -O0 one-of-the-packages+To force recompilation manually, use the `--force-dirty` flag. If this still doesn't lead to a rebuild,+add the `-fforce-recomp` flag to your `--ghc-options`. -This may end up recompiling local dependencies of `one-of-the-packages` without optimizations on. Whether stack should or shouldn't do this depends on the needs of the user at the time, and unfortunately we can't make a solution that will make everyone happy in all cases. If you're curious for details, there's [a long discussion about it](https://github.com/commercialhaskell/stack/issues/382) on the issue tracker.+## Why doesn't stack apply my `--ghc-options` to my dependencies? +By default, stack applies command line GHC options only to local packages (these are all+the packages that are specified in the `packages` section of your `stack.yaml`).+For an explanation of this choice see [this discussion on the issue tracker](https://github.com/commercialhaskell/stack/issues/827#issuecomment-133263678).++If you still want to set specific GHC options for a dependency, use the [`ghc-options` option](yaml_configuration.md#ghc-options) in your+`stack.yaml` or global `~/.stack/config.yaml`.++To change the set of packages that command line GHC options apply to, use the [`apply-ghc-options` option](yaml_configuration.md#apply-ghc-options).+ ## stack setup on a windows system only tells me to add certain paths to the PATH variable instead of doing it  If you are using a powershell session, it is easy to automate even that step:@@ -280,8 +293,7 @@  ## I get strange `ld` errors about recompiling with "-fPIC" -Some users (myself included!) have come across a linker errors (example below) that seem to be dependent on the local environment, i.e. the package may compile on a different machine. There is no known workaround (if you come across one please include details), however the issue has been reported to be [non-deterministic](https://github.com/commercialhaskell/stack/issues/614)-in some cases. I've had success using the docker functionality to build the project on a machine that would not compile it otherwise.+Some users (myself included!) have come across a linker errors (example below) that seem to be dependent on the local environment, i.e. the package may compile on a different machine. The issue has been reported to be [non-deterministic](https://github.com/commercialhaskell/stack/issues/614) in some cases. I've had success using the docker functionality to build the project on a machine that would not compile it otherwise.  ``` tmp-0.1.0.0: build@@ -297,6 +309,15 @@     Process exited with code: ExitFailure 1 ``` +The issue may be related to the use of hardening flags in some cases, specifically those related to producing position independent executables (PIE). This is tracked upstream in the [following ticket](https://ghc.haskell.org/trac/ghc/ticket/9007). Some distributions add such hardening flags by default which may be the cause of some instances of the 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.++If you manage to work around this in other distributions, please include instructions here.+ ## Where does the output from `--ghc-options=-ddump-splices` (and other `-ddump*` options) go?  These are written to `*.dump-*` files inside the package's `.stack-work` directory.@@ -331,3 +352,35 @@     stack exec "--" cabal --version  This is known to be a problem on Windows 7, but seems to be fixed on Windows 10.++## Does stack also install the system/C libraries that some Cabal packages depend on?++No, this is currently out of the scope of stack's target set of features.+Instead of attempting to automate the installation of 3rd party dependencies, we+have the following approaches for handling system dependencies:++* Nix and docker help make your build and execution environment deterministic+  and predictable. This way, you can install system dependencies into a+  container, and share this container with all developers.++* If you have installed some libraries into a non-standard location,+  [`extra-lib-dirs` / `extra-include-dirs`](yaml_configuration.md#extra-include-dirsextra-lib-dirs)+  to specify it.++In the future, stack might give OS specific suggestions for how to install+system libraries.++## How can I make `stack` aware of my custom SSL certificates?++### OS X++In principle, you can use the following command to add a certificate to your system certificate keychain:++    sudo security add-trusted-cert -d -r trustRoot -k /Library/Keychains/System.keychain <certificate>++Some users have reported issues with this approach, see [#907](https://github.com/commercialhaskell/stack/issues/907) for more information.++### Other *NIX OSs++Use the `SYSTEM_CERTIFICATE_PATH` environment variable to point at the directory+where you keep your SSL certificates.
doc/install_and_upgrade.md view
@@ -1,5 +1,13 @@ # Install/upgrade +For many Un*x operating systems, all you need to do is run:++    curl -sSL https://get.haskellstack.org/ | sh++or:++    wget -qO- https://get.haskellstack.org/ | sh+ Distribution packages are available for [Ubuntu](#ubuntu), [Debian](#debian), [CentOS / Red Hat / Amazon Linux](#centos), [Fedora](#fedora), [Arch Linux](#arch-linux) and unofficially [FreeBSD](#freebsd).@@ -58,13 +66,10 @@  If you have a popular [brew](http://brew.sh/) tool installed, you can just do: -```-brew install haskell-stack-```+    brew install haskell-stack -* The Homebrew formula and bottles lag slightly behind new Stack releases,+* The Homebrew formula and bottles are **unofficial** and lag slightly behind new Stack releases, but tend to be updated within a day or two.-* At later stage, running `stack setup` might fail with `configure: error: cannot run C compiled programs.` in which case you should run `xcode-select --install`. * Normally, Homebrew will install from a pre-built binary (aka "pour from a bottle"), but if `brew` starts trying to build everything from source (which will take hours), see@@ -83,13 +88,16 @@  ### Notes +After installation, running `stack setup` might fail with `configure: error: cannot run C compiled programs.` in which case you should run:++    xcode-select --install+ If you are on OS X 10.11 ("El Capitan") and encounter either of these problems, see the linked FAQ entries:    * [GHC 7.8.4 fails with `/usr/bin/ar: permission denied`](faq.md#usr-bin-ar-permission-denied)   * [DYLD_LIBRARY_PATH is ignored](faq.md#dyld-library-path-ignored) - ## Ubuntu  *note*: for 32-bit, use the [generic Linux option](#linux)@@ -100,6 +108,10 @@   2. Add the appropriate source repository (if not sure, run ``lsb_release -a`` to find out your Ubuntu version): +      * Ubuntu 16.10 (amd64):++            echo 'deb http://download.fpcomplete.com/ubuntu yakkety main'|sudo tee /etc/apt/sources.list.d/fpco.list+       * Ubuntu 16.04 (amd64):              echo 'deb http://download.fpcomplete.com/ubuntu xenial main'|sudo tee /etc/apt/sources.list.d/fpco.list@@ -154,11 +166,11 @@        * CentOS 7 / RHEL 7 (x86_64) -            curl -sSL https://s3.amazonaws.com/download.fpcomplete.com/centos/7/fpco.repo | sudo tee /etc/yum.repos.d/fpco.repo+            curl -sSL https://download.fpcomplete.com/centos/7/fpco.repo | sudo tee /etc/yum.repos.d/fpco.repo        * CentOS 6 / RHEL 6 (x86_64) -            curl -sSL https://s3.amazonaws.com/download.fpcomplete.com/centos/6/fpco.repo | sudo tee /etc/yum.repos.d/fpco.repo+            curl -sSL https://download.fpcomplete.com/centos/6/fpco.repo | sudo tee /etc/yum.repos.d/fpco.repo   2. Install: @@ -173,13 +185,17 @@     1. Add the appropriate source repository: +      * Fedora 24 (x86_64)++            curl -sSL https://download.fpcomplete.com/fedora/24/fpco.repo | sudo tee /etc/yum.repos.d/fpco.repo+       * Fedora 23 (x86_64) -            curl -sSL https://s3.amazonaws.com/download.fpcomplete.com/fedora/23/fpco.repo | sudo tee /etc/yum.repos.d/fpco.repo+            curl -sSL https://download.fpcomplete.com/fedora/23/fpco.repo | sudo tee /etc/yum.repos.d/fpco.repo        * Fedora 22 (x86_64) -            curl -sSL https://s3.amazonaws.com/download.fpcomplete.com/fedora/22/fpco.repo | sudo tee /etc/yum.repos.d/fpco.repo+            curl -sSL https://download.fpcomplete.com/fedora/22/fpco.repo | sudo tee /etc/yum.repos.d/fpco.repo     2. Install: @@ -211,16 +227,22 @@  ## Arch Linux -*Note:* `stack` package in the [community] repository isn't managed by the +*Note:* `stack` package in the [community] repository isn't managed by the Stack release team. Depending on the maintainer's availability, it can lag new releases by some days.    - [stack](https://www.archlinux.org/packages/community/x86_64/stack/) _latest stable version_   - [haskell-stack-git](https://aur.archlinux.org/packages/haskell-stack-git/) _git version_ -In order to install stack from Hackage or from source, you will need the [libtinfo-5](https://aur.archlinux.org/packages/libtinfo-5/) Arch Linux package installed.  If this package is not installed, stack will not be able to install GHC.+In order to use `stack setup` with older versions of GHC or on a 32-bit system,+you may need the+[ncurses5-compat-libs](https://aur.archlinux.org/packages/ncurses5-compat-libs/)+AUR package installed. If this package is not installed, Stack may not be able+to install older (< 7.10.3) or 32-bit GHC versions. -If you use the [ArchHaskell repository](https://wiki.archlinux.org/index.php/ArchHaskell), you can also get the `haskell-stack-tool` package from there.+If you use the+[ArchHaskell repository](https://wiki.archlinux.org/index.php/ArchHaskell), you+can also get the `haskell-stack-tool` package from there.  ## NixOS @@ -246,7 +268,7 @@  For more information on using Stack together with Nix, please see [the NixOS manual section on-Stack](http://nixos.org/nixpkgs/manual/#using-stack-together-with-nix).+Stack](http://nixos.org/nixpkgs/manual/#how-to-build-a-haskell-project-using-stack).  ## Linux @@ -264,11 +286,24 @@  * Extract the archive and place `stack` somewhere on your `$PATH` (see [Path section below](#path)) -* Now you can run `stack` from the terminal.+* Ensure you have required system dependencies installed.  These include GCC, GNU make, xz, perl, libgmp, libffi, and zlib.  We also recommend Git and GPG.  To install these using your package manager:+    * Debian / Ubuntu: `sudo apt-get install g++ gcc libc6-dev libffi-dev libgmp-dev make xz-utils zlib1g-dev git gnupg`+    * Fedora / CentOS: `sudo dnf install perl make automake gcc gmp-devel libffi zlib xz tar git gnupg` (use `yum` instead of `dnf` on CentOS and Fedora <= 21)+        * Fedora 24: In order to use `stack setup` on a 32-bit system, you may+          need to run `sudo dnf install ncurses-compat-libs`. If this package is+          not installed, Stack may not be able to install 32-bit GHC versions.+        Also `sudo dnf install ncurses-compat-libs` if you nee+    * Arch Linux: `sudo pacman -S make gcc ncurses git gnupg xz zlib gmp libffi zlib` -Tested on Fedora 20: make sure to install the following packages `sudo yum install perl make automake gcc gmp-devel`.-For Gentoo users, make sure to have the `ncurses` package with `USE=tinfo` (without it, stack will not be able to install GHC).+        * In order to use `stack setup` with older versions of GHC or on a+          32-bit system, you may need the+          [ncurses5-compat-libs](https://aur.archlinux.org/packages/ncurses5-compat-libs/)+          AUR package installed. If this package is not installed, Stack may not+          be able to install older (< 7.10.3) or 32-bit GHC versions.+    * Gentoo users, make sure to have the `ncurses` package with `USE=tinfo` (without it, stack will not be able to install GHC). +* Now you can run `stack` from the terminal.+ ## FreeBSD  (only 64-bit currently available, tested on FreeBSD 10.3-RELEASE)@@ -287,8 +322,7 @@  An unofficial package repository for FreeBSD 10 (amd64 only) and install instructions are available at [http://stack-pkg.applicative.tech](http://stack-pkg.applicative.tech/).  The-repository is not official and as such might lag behind new releases.  See [issue #1253](https://github.com/commercialhaskell/stack/issues/1253)-for progress on official FreeBSD binaries.+repository is not official and as such might lag behind new releases.  ## Path
doc/nix_integration.md view
@@ -2,8 +2,8 @@  (since 0.1.10.0) -When using the Nix integration, Haskell dependencies are handled as usual: they-are downloaded from Stackage and build locally by Stack. Nix is used by Stack to+When using the Nix integration, Haskell dependencies are handled as usual: They+are downloaded from Stackage and built locally by Stack. Nix is used by Stack to provide the _non-Haskell_ dependencies needed by these Haskell packages.  `stack` can automatically create a build environment (the equivalent@@ -40,37 +40,36 @@ support means packages will always be built using a GHC available inside the shell, rather than your globally installed one if any. -Note that in this mode `stack` can use only those resolvers that have-already been mirrored into the Nix package repository. The-[Nixpkgs master branch](https://github.com/NixOS/nixpkgs/tree/master/pkgs/development/haskell-modules)-usually picks up new resolvers such as Stackage nightlies and LTS-versions within two or three days. Then it takes another two or three+Note that in this mode `stack` can use only GHC versions than have+already been mirrored into the Nix package repository.+The [Nixpkgs master branch](https://github.com/NixOS/nixpkgs/tree/master/pkgs/development/haskell-modules)+usually picks up new versions quickly, but it takes two or three days before those updates arrive in the `unstable` channel. Release channels, like `nixos-15.09`, receive those updates only occasionally -- say, every two or three months --, so you should not-expect them to have the latest resolvers available. Fresh Nix installs+expect them to have the latest compiler available. Fresh NixOS installs use a release version by default. -To know for sure whether a given resolver as available on your system,+To know for sure whether a given compiler is available on your system, you can use the command  ```sh-$ nix-env -f "<nixpkgs>" -qaP -A haskell.packages.lts-3_13.ghc-haskell.packages.lts-3_13.ghc  ghc-7.10.2+$ nix-env -f "<nixpkgs>" -qaP -A haskell.compiler.ghc801+haskell.compiler.ghc801  ghc-8.0.1 ```  to check whether it's available. If Nix doesn't know that resolver yet, then you'll see the following error message instead:  ```sh-$ nix-env -f "<nixpkgs>" -qaP -A haskell.packages.lts-3_99.ghc-error: attribute ‘lts-3_99’ in selection path ‘haskell.packages.lts-3_99.ghc’ not found+$ nix-env -f "<nixpkgs>" -qaP -A haskell.compiler.ghc999+error: attribute ‘ghc999’ in selection path ‘haskell.compiler.ghc999’ not found ``` -You can list all known Haskell package sets in Nix with the following:+You can list all known Haskell compilers in Nix with the following:  ```sh-$ nix-instantiate --eval -E "with import <nixpkgs> {}; lib.attrNames haskell.packages"+$ nix-instantiate --eval -E "with import <nixpkgs> {}; lib.attrNames haskell.compiler" ```  Alternatively, install `nix-repl`, a convenient tool to explore@@ -86,7 +85,7 @@  ```sh nix-repl> :l <nixpkgs>-nix-repl> haskell.packages.lts-<Tab>+nix-repl> haskell.compiler.ghc<Tab> ```  You can type and evaluate any nix expression in the nix-repl, such as@@ -200,20 +199,25 @@ 2015-03-05):  ```nix+{ghc}: with (import <nixpkgs> {});  haskell.lib.buildStackProject {+  inherit ghc;   name = "myEnv";   buildInputs = [ glpk pcre ]; } ``` -Defining manually a `shell.nix` file gives you the possibility to-override some Nix derivations ("packages"), for instance to change-some build options of the libraries you use, or to set additional-environment variables. See the [Nix manual][nix-manual-exprs] for-more. The `buildStackProject` utility function is documented in the-[Nixpkgs manual][nixpkgs-manual-haskell].+Defining manually a `shell.nix` file gives you the possibility to override some+Nix derivations ("packages"), for instance to change some build options of the+libraries you use, or to set additional environment variables. See the+[Nix manual][nix-manual-exprs] for more. The `buildStackProject` utility+function is documented in the [Nixpkgs manual][nixpkgs-manual-haskell].  In such+case, stack expect this file to define a function of exactly one argument that+should be called `ghc` (as arguments within a set are non-positional), which you+should give to `buildStackProject`. This is the ghc from the resolver you set in+the `stack.yaml`.  And now for the `stack.yaml` file:
doc/yaml_configuration.md view
@@ -2,11 +2,11 @@  This page is intended to fully document all configuration options available in the stack.yaml file. Note that this page is likely to be both *incomplete* and sometimes *inaccurate*. If you see such cases, please update the page, and if you're not sure how, open an issue labeled "question". -The stack.yaml configuration options break down into [project specific](#project-config) options in:+The stack.yaml configuration options break down into [project-specific](#project-config) options in:  - `<project dir>/stack.yaml` -and [non-project specific](#non-project-config) options in:+and [non-project-specific](#non-project-config) options in:  - `/etc/stack/config.yaml` -- for system global non-project default options -  `~/.stack/config.yaml` -- for user non-project default options@@ -14,10 +14,27 @@  *Note:* When stack is invoked outside a stack project it will source project specific options from `~/.stack/global/stack.yaml`.  Options in this file will be ignored for a project with its own `<project dir>/stack.yaml`. -## Project config+## Project-specific config -Project specific options are only valid in the `stack.yaml` file local to a project, not in the user or global config files.+Project-specific options are only valid in the `stack.yaml` file local to a+project, not in the user or global config files. +> 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.++In your project-specific options, you specify both **which local packages** to+build and **which dependencies to use** when building these packages. Unlike the+user's local packages, these dependencies aren't built by default. They only get+built when needed.++Shadowing semantics, described+[here](http://docs.haskellstack.org/en/stable/architecture/#shadowing), are+applied to your configuration. So, if you add a package to your `packages` list,+it will be used even if you're using a snapshot that specifies a particular+version. Similarly, `extra-deps` will shadow the version specified in the+resolver.+ ### packages  The `packages` section lists all local (project) packages. The term  _local@@ -222,7 +239,7 @@ needed. The user can delete this message if the generated configuration is acceptable. -## Non-project config+## Non-project-specific config  Non-project config options may go in the global config (`/etc/stack/config.yaml`) or the user config (`~/.stack/config.yaml`). @@ -328,6 +345,14 @@ - /opt/foo/lib ``` +### with-gcc++Specify a path to gcc explicitly, rather than relying on the normal path resolution.++```yaml+with-gcc: /usr/local/bin/gcc-5+```+ ### compiler-check  (Since 0.1.4)@@ -371,8 +396,32 @@ 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 local packages.+affect the packages specified by the [`apply-ghc-options` option](yaml_configuration.md#apply-ghc-options). +### apply-ghc-options++(Since 0.1.6)++Which packages do ghc-options on the command line get applied to? Before 0.1.6, the default value was `targets`++```yaml+apply-ghc-options: locals # all local packages, the default+# apply-ghc-options: targets # all local packages that are targets+# apply-ghc-options: everything # applied even to snapshot and extra-deps+```++Note that `everything` is a slightly dangerous value, as it can break invariants about your snapshot database.++### rebuild-ghc-options++(Since 0.1.6)++Should we rebuild a package when its GHC options change? Before 0.1.6, this was a non-configurable true. However, in most cases, the flag is used to affect optimization levels and warning behavior, for which GHC itself doesn't actually recompile the modules anyway. Therefore, the new behavior is to not recompile on an options change, but this behavior can be changed back with the following:++```yaml+rebuild-ghc-options: true+```+ ### ghc-variant  (Since 0.1.5)@@ -380,8 +429,6 @@ Specify a variant binary distribution of GHC to use.  Known values:  * `standard`: This is the default, uses the standard GHC binary distribution-* `gmp4`: Use the "centos6" GHC bindist, for Linux systems with libgmp4 (aka-  `libgmp.so.3`), such as CentOS 6. This variant will be used automatically on such systems; you should not need to specify it in the configuration * `integersimple`: Use a GHC bindist that uses   [integer-simple instead of GMP](https://ghc.haskell.org/trac/ghc/wiki/ReplacingGMPNotes) * any other value: Use a custom GHC bindist. You should specify@@ -404,6 +451,8 @@         url: "https://example.com/ghc-7.10.2-i386-unknown-mingw32-foo.tar.xz" ``` +`url` may be either URL or (since 1.2.0) absolute file path.+ ### pvp-bounds  (Since 0.1.5)@@ -455,30 +504,6 @@     entropy: false # override the new default for one package ``` -### rebuild-ghc-options--(Since 0.1.6)--Should we rebuild a package when its GHC options change? Before 0.1.6, this was a non-configurable true. However, in most cases, the flag is used to affect optimization levels and warning behavior, for which GHC itself doesn't actually recompile the modules anyway. Therefore, the new behavior is to not recompile on an options change, but this behavior can be changed back with the following:--```yaml-rebuild-ghc-options: true-```--### apply-ghc-options--(Since 0.1.6)--Which packages do ghc-options on the command line get applied to? Before 0.1.6, the default value was `targets`--```yaml-apply-ghc-options: locals # all local packages, the default-# apply-ghc-options: targets # all local packages that are targets-# apply-ghc-options: everything # applied even to snapshot and extra-deps-```--Note that `everything` is a slightly dangerous value, as it can break invariants about your snapshot database.- ### allow-newer  (Since 0.1.7)@@ -508,6 +533,42 @@  The option is automatically enabled when `stack` is re-spawned in a Docker process. +### build++(Since 1.1.0)++Allows setting build options which are usually specified on the CLI.  Here are+the settings with their defaults:++```yaml+build:+  library-profiling: false+  executable-profiling: false+  copy-bins: false+  prefetch: false+  keep-going: false++  # NOTE: global usage of haddock can cause build failures when documentation is+  # incorrectly formatted.  This could also affect scripts which use stack.+  haddock: false+  haddock-arguments: ""+  open-haddocks: false    # --open+  haddock-deps: false     # if unspecified, defaults to true if haddock is set++  # These are inadvisable to use in your global configuration, as they make the+  # stack build CLI behave quite differently.+  test: false+  test-arguments: ""+  bench: false+  benchmark-opts: ""+  force-dirty: false+  reconfigure: false+```++The meanings of these settings correspond directly with the CLI flags of the+same name. See the [build command docs](build_command.md) and the+[users guide](GUIDE.md#the-build-command) for more info.+ ### templates  Templates used with `stack new` have a number of parameters that affect the generated code. These can be set for all new projects you create. The result of them can be observed in the generated LICENSE and cabal files.@@ -519,6 +580,7 @@ * _category_ - sets the `category` property in cabal. This is used in Hackage. For examples of categories see [Packages by category](https://hackage.haskell.org/packages/). It makes sense for `category` to be set on a per project basis because it is uncommon for all projects a user creates to belong to the same category. The category can be 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` * _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:+ ```yaml homepage: http://github.com/myusername/my-project#readme @@ -537,3 +599,19 @@     copyright: 'Copyright: (c) 2016 Your Name'     github-username: yourusername ```++# urls++Customize the URLs where `stack` looks for snapshot build plans.++The default configuration is++```yaml+urls:+  latest-snapshot: https://www.stackage.org/download/snapshots.json+  lts-build-plans: https://raw.githubusercontent.com/fpco/lts-haskell/master/+  nightly-build-plans: https://raw.githubusercontent.com/fpco/stackage-nightly/master/+```++**Note:** The `latest-snapshot-url` field has been deprecated in favor of `latest-snapshot`+and will be removed in a future version of `stack`.
src/Control/Concurrent/Execute.hs view
@@ -20,7 +20,7 @@ import qualified Data.Set                 as Set import           Data.Typeable            (Typeable) import           Prelude -- Fix AMP warning-import           Stack.Types+import           Stack.Types.PackageIdentifier  data ActionType     = ATBuild
− src/Data/Binary/VersionTagged.hs 
@@ -1,90 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ConstraintKinds #-}--- | Tag a Binary instance with the stack version number to ensure we're--- reading a compatible format.-module Data.Binary.VersionTagged-    ( taggedDecodeOrLoad-    , taggedEncodeFile-    , Binary (..)-    , BinarySchema-    , HasStructuralInfo-    , HasSemanticVersion-    , decodeFileOrFailDeep-    , NFData (..)-    ) where--import Control.DeepSeq (NFData (..))-import Control.Exception (Exception)-import Control.Monad.Catch (MonadThrow (..))-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Logger-import Data.Binary (Binary (..))-import Data.Binary.Get (ByteOffset)-import Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion)-import qualified Data.Binary.Tagged as BinaryTagged-import Data.Monoid ((<>))-import Data.Typeable (Typeable)-import Control.Exception.Enclosed (tryAnyDeep)-import Path-import Path.IO (ensureDir)-import qualified Data.Text as T--type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a)---- | Write to the given file, with a binary-tagged tag.-taggedEncodeFile :: (BinarySchema a, MonadIO m)-                 => Path Abs File-                 -> a-                 -> m ()-taggedEncodeFile fp x = liftIO $ do-    ensureDir (parent fp)-    BinaryTagged.taggedEncodeFile (toFilePath fp) x---- | Read from the given file. If the read fails, run the given action and--- write that back to the file. Always starts the file off with the version--- tag.-taggedDecodeOrLoad :: (BinarySchema a, MonadIO m, MonadLogger m)-                   => Path Abs File-                   -> m a-                   -> m a-taggedDecodeOrLoad fp mx = do-    let fpt = T.pack (toFilePath fp)-    $logDebug $ "Trying to decode " <> fpt-    eres <- decodeFileOrFailDeep fp-    case eres of-        Left _ -> do-            $logDebug $ "Failure decoding " <> fpt-            x <- mx-            taggedEncodeFile fp x-            return x-        Right x -> do-            $logDebug $ "Success decoding " <> fpt-            return x---- | Ensure that there are no lurking exceptions deep inside the parsed--- value... because that happens unfortunately. See--- https://github.com/commercialhaskell/stack/issues/554-decodeFileOrFailDeep :: (BinarySchema a, MonadIO m, MonadThrow n)-                     => Path loc File-                     -> m (n a)-decodeFileOrFailDeep fp = liftIO $ fmap (either throwM return) $ tryAnyDeep $ do-    eres <- BinaryTagged.taggedDecodeFileOrFail (toFilePath fp)-    case eres of-        Left (offset, str) -> throwM $ DecodeFileFailure (toFilePath fp) offset str-        Right x -> return x--data DecodeFileFailure = DecodeFileFailure FilePath ByteOffset String-    deriving Typeable-instance Show DecodeFileFailure where-    show (DecodeFileFailure fp offset str) = concat-        [ "Decoding of "-        , fp-        , " failed at offset "-        , show offset-        , ": "-        , str-        ]-instance Exception DecodeFileFailure
+ src/Data/Store/VersionTagged.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+-- | Tag a Store instance with structural version info to ensure we're+-- reading a compatible format.+module Data.Store.VersionTagged+    ( versionedEncodeFile+    , versionedDecodeOrLoad+    , versionedDecodeFile+    , storeVersionConfig+    ) where++import 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 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.Version+import qualified Data.Text as T+import Language.Haskell.TH+import Path+import Path.IO (ensureDir)+import Prelude++versionedEncodeFile :: Data a => VersionConfig a -> Q Exp+versionedEncodeFile vc = [e| \fp x -> storeEncodeFile fp ($(wrapVersion vc) x) |]++versionedDecodeOrLoad :: Data a => VersionConfig a -> Q Exp+versionedDecodeOrLoad vc = [| versionedDecodeOrLoadImpl $(wrapVersion vc) $(checkVersion vc) |]++versionedDecodeFile :: Data a => VersionConfig a -> Q Exp+versionedDecodeFile vc = [e| versionedDecodeFileImpl $(checkVersion vc) |]++-- | Write to the given file.+storeEncodeFile :: (Store a, MonadIO m, MonadLogger m, Eq a)+                => Path Abs File+                -> a+                -> m ()+storeEncodeFile fp x = do+    let fpt = T.pack (toFilePath fp)+    $logDebug $ "Encoding " <> fpt+    ensureDir (parent fp)+    let encoded = encode x+    assert (decodeEx encoded == x) $ liftIO $ BS.writeFile (toFilePath fp) encoded+    $logDebug $ "Finished writing " <> fpt++-- | Read from the given file. If the read fails, run the given action and+-- write that back to the file. Always starts the file off with the+-- version tag.+versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadIO m, MonadLogger m, MonadBaseControl IO m)+                          => (a -> WithVersion a)+                          -> (WithVersion a -> Either VersionCheckException a)+                          -> Path Abs File+                          -> m a+                          -> m a+versionedDecodeOrLoadImpl wrap check fp mx = do+    let fpt = T.pack (toFilePath fp)+    $logDebug $ "Trying to decode " <> fpt+    mres <- versionedDecodeFileImpl check fp+    case mres of+        Just x -> do+            $logDebug $ "Success decoding " <> fpt+            return x+        _ -> do+            $logDebug $ "Failure decoding " <> fpt+            x <- mx+            storeEncodeFile fp (wrap x)+            return x++versionedDecodeFileImpl :: (Store a, MonadIO m, MonadLogger m, MonadBaseControl IO m)+                        => (WithVersion a -> Either VersionCheckException a)+                        -> Path loc File+                        -> m (Maybe a)+versionedDecodeFileImpl check 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))+        return Nothing+    case mbs of+        Nothing -> return Nothing+        Just bs ->+            liftIO (do decoded <- decodeIO bs+                       return $ case check decoded of+                           Right res -> Just res+                           _ -> Nothing) `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)")+                 return Nothing++storeVersionConfig :: String -> String -> VersionConfig a+storeVersionConfig name hash = (namedVersionConfig name hash)+    { vcIgnore = S.fromList+        [ "Data.Vector.Unboxed.Base.Vector GHC.Types.Word"+        , "Data.ByteString.Internal.ByteString"+        ]+    , vcRenames = M.fromList+        [ ( "Data.Maybe.Maybe", "GHC.Base.Maybe") ]+    }
+ src/Data/Yaml/Extra.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | Wrappers for Yaml functions to workaround+-- https://github.com/commercialhaskell/stack/issues/2491.+-- Import Data.Yaml.Extra in place of Data.Yaml to use this workaround.+-- Beware these functions construct/deconstruct the entire file at once!+module Data.Yaml.Extra (decodeFileEither, encodeFile, module Data.Yaml) where++import           Control.Exception+import           Data.Yaml hiding (decodeFileEither, encodeFile)+import qualified Data.ByteString as B+import           System.IO++-- Note: we refrain from using 'B.readFile' and 'B.writeFile', as they open+-- the file in binary mode rather than text mode.+decodeFileEither :: FromJSON a => FilePath -> IO (Either ParseException a)+decodeFileEither path =+  handle (\(e :: IOException) -> return . Left . OtherParseException . SomeException $ e) $+  withFile path ReadMode $+  \hnd -> do+    fileContent <- B.hGetContents hnd+    return $ decodeEither' fileContent++encodeFile :: ToJSON a => FilePath -> a -> IO ()+encodeFile path v = withFile path WriteMode $+  \hnd -> do+    let fileContent = encode v+    B.hPut hnd fileContent
src/Network/HTTP/Download.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                   #-} {-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-}@@ -16,7 +15,8 @@     , download     , redownload     , downloadJSON-    , parseUrl+    , parseRequest+    , parseUrlThrow     , liftHTTP     , ask     , getHttpManager@@ -46,10 +46,10 @@ import           Data.Text.Encoding.Error    (lenientDecode) import           Data.Text.Encoding          (decodeUtf8With) import           Data.Typeable               (Typeable)-import           Network.HTTP.Client         (path)+import           Network.HTTP.Client         (path, checkResponse) import           Network.HTTP.Client.Conduit (HasHttpManager, Manager, Request,-                                              Response, checkStatus,-                                              getHttpManager, parseUrl,+                                              Response, parseRequest,+                                              getHttpManager, parseUrlThrow,                                               requestHeaders, responseBody,                                               responseHeaders, responseStatus,                                               withResponse)@@ -108,7 +108,7 @@                         requestHeaders req0 ++                         [("If-None-Match", L.toStrict etag)]                     }-        req2 = req1 { checkStatus = \_ _ _ -> Nothing }+        req2 = req1 { checkResponse = \_ _ -> return () }     env <- ask     liftIO $ recoveringHttp drRetryPolicyDefault $ flip runReaderT env $       withResponse req2 $ \res -> case () of
src/Network/HTTP/Download/Verified.hs view
@@ -37,6 +37,7 @@ import              Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay) import "cryptohash" Crypto.Hash import              Crypto.Hash.Conduit (sinkHash)+import              Data.Byteable (toBytes) import              Data.ByteString (ByteString) import              Data.ByteString.Char8 (readInteger) import              Data.Conduit@@ -115,7 +116,7 @@     show (WrongDigest req algo expected actual) =         "Download expectation failure: content hash (" ++ algo ++  ")\n"         ++ "Expected: " ++ displayCheckHexDigest expected ++ "\n"-        ++ "Actual:   " ++ actual ++ "\n"+        ++ "Actual:   " ++ show actual ++ "\n"         ++ "For: " ++ show (getUri req)  instance Exception VerifiedDownloadException@@ -138,8 +139,7 @@ displayCheckHexDigest (CheckHexDigestString s) = s ++ " (String)" displayCheckHexDigest (CheckHexDigestByteString s) = displayByteString s ++ " (ByteString)" displayCheckHexDigest (CheckHexDigestHeader h) =-      displayByteString (B64.decodeLenient h) ++ " (Header. unencoded: "-      ++ displayByteString h ++ ")"+      show (B64.decodeLenient h) ++ " (Header. unencoded: " ++ show h ++ ")"   -- | Make sure that the hash digest for a finite stream of bytes@@ -154,11 +154,13 @@     digest <- sinkHashUsing hashCheckAlgorithm     let actualDigestString = show digest     let actualDigestHexByteString = digestToHexByteString digest+    let actualDigestBytes = toBytes digest      let passedCheck = case hashCheckHexDigest of           CheckHexDigestString s -> s == actualDigestString           CheckHexDigestByteString b -> b == actualDigestHexByteString           CheckHexDigestHeader b -> B64.decodeLenient b == actualDigestHexByteString+            || B64.decodeLenient b == actualDigestBytes             -- A hack to allow hackage tarballs to download.             -- They should really base64-encode their md5 header as per rfc2616#sec14.15.             -- https://github.com/commercialhaskell/stack/issues/240
src/Options/Applicative/Builder/Extra.hs view
@@ -12,12 +12,19 @@   ,textOption   ,textArgument   ,optionalFirst+  ,absFileOption+  ,relFileOption+  ,absDirOption+  ,relDirOption+  ,eitherReader'   ) where  import Control.Monad (when)+import Data.Either.Combinators import Data.Monoid import Options.Applicative import Options.Applicative.Types (readerAsk)+import Path import System.Environment (withArgs) import System.FilePath (takeBaseName) import Data.Text (Text)@@ -136,3 +143,19 @@ -- | Like 'optional', but returning a 'First'. optionalFirst :: Alternative f => f a -> f (First a) optionalFirst = fmap First . optional++absFileOption :: Mod OptionFields (Path Abs File) -> Parser (Path Abs File)+absFileOption = option (eitherReader' parseAbsFile)++relFileOption :: Mod OptionFields (Path Rel File) -> Parser (Path Rel File)+relFileOption = option (eitherReader' parseRelFile)++absDirOption :: Mod OptionFields (Path Abs Dir) -> Parser (Path Abs Dir)+absDirOption = option (eitherReader' parseAbsDir)++relDirOption :: Mod OptionFields (Path Rel Dir) -> Parser (Path Rel Dir)+relDirOption = option (eitherReader' parseRelDir)++-- | Like 'eitherReader', but accepting any @'Show' e@ on the 'Left'.+eitherReader' :: Show e => (String -> Either e a) -> ReadM a+eitherReader' f = eitherReader (mapLeft show . f)
src/Options/Applicative/Complicated.hs view
@@ -34,7 +34,9 @@   -> String   -- ^ header   -> String-  -- ^ program description+  -- ^ program description (displayed between usage and options listing in the help output)+  -> String+  -- ^ footer   -> Parser a   -- ^ common settings   -> Maybe (ParserFailure ParserHelp -> [String] -> IO (a,(b,a)))@@ -43,7 +45,7 @@   -> EitherT b (Writer (Mod CommandFields (b,a))) ()   -- ^ commands (use 'addCommand')   -> IO (a,b)-complicatedOptions numericVersion versionString numericHpackVersion h pd commonParser mOnFailure commandParser =+complicatedOptions numericVersion versionString numericHpackVersion h pd footerStr commonParser mOnFailure commandParser =   do args <- getArgs      (a,(b,c)) <- case execParserPure (prefs noBacktrack) parser args of        Failure _ | null args -> withArgs ["--help"] (execParser parser)@@ -52,7 +54,7 @@        parseResult -> handleParseResult parseResult      return (mappend c a,b)   where parser = info (helpOption <*> versionOptions <*> complicatedParser commonParser commandParser) desc-        desc = fullDesc <> header h <> progDesc pd+        desc = fullDesc <> header h <> progDesc pd <> footer footerStr         versionOptions =           case versionString of             Nothing -> versionOption (showVersion numericVersion)@@ -139,9 +141,9 @@ hsubparser' :: Mod CommandFields a -> Parser a hsubparser' m = mkParser d g rdr   where-    Mod _ d g = m `mappend` metavar "COMMAND|FILE"-    (cmds, subs) = mkCommand m-    rdr = CmdReader cmds (fmap add_helper . subs)+    Mod _ d g = metavar "COMMAND|FILE" `mappend` m+    (groupName, cmds, subs) = mkCommand m+    rdr = CmdReader groupName cmds (fmap add_helper . subs)     add_helper pinfo = pinfo       { infoParser = infoParser pinfo <**> helpOption }
src/Path/Extra.hs view
@@ -9,8 +9,15 @@   ,parseCollapsedAbsFile   ,rejectMissingFile   ,rejectMissingDir+  ,pathToByteString+  ,pathToLazyByteString+  ,pathToText   ) 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@@ -94,3 +101,14 @@   -> m (Maybe (Path Abs Dir)) rejectMissingDir Nothing = return Nothing rejectMissingDir (Just p) = bool Nothing (Just p) `liftM` doesDirExist p++-- | Convert to a lazy ByteString using toFilePath and UTF8.+pathToLazyByteString :: Path b t -> BSL.ByteString+pathToLazyByteString = BSL.fromStrict . pathToByteString++-- | Convert to a ByteString using toFilePath and UTF8.+pathToByteString :: Path b t -> BS.ByteString+pathToByteString = T.encodeUtf8 . pathToText++pathToText :: Path b t -> T.Text+pathToText = T.pack . toFilePath
src/Stack/Build.hs view
@@ -60,8 +60,17 @@ import           Stack.Fetch as Fetch import           Stack.GhcPkg import           Stack.Package-import           Stack.Types+import           Stack.Types.FlagName+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.Internal+#ifdef WINDOWS+import           Stack.Types.Compiler+#endif import           System.FileLock (FileLock, unlockFile)  #ifdef WINDOWS@@ -69,7 +78,7 @@ import qualified Control.Monad.Catch as Catch #endif -type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseUnlift IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)+type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLoggerIO m,MonadBaseUnlift IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)  -- | Build. --@@ -161,7 +170,8 @@ -- | See https://github.com/commercialhaskell/stack/issues/1198. warnIfExecutablesWithSameNameCouldBeOverwritten     :: MonadLogger m => [LocalPackage] -> Plan -> m ()-warnIfExecutablesWithSameNameCouldBeOverwritten locals plan =+warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do+    $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:"
src/Stack/Build/Cache.hs view
@@ -4,13 +4,16 @@ {-# LANGUAGE TupleSections         #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# OPTIONS_GHC -fno-warn-orphans  #-} -- | Cache information about previous builds module Stack.Build.Cache     ( tryGetBuildCache     , tryGetConfigCache     , tryGetCabalMod     , getInstalledExes-    , buildCacheTimes     , tryGetFlagCache     , deleteCaches     , markExeInstalled@@ -24,31 +27,50 @@     , checkTestSuccess     , writePrecompiledCache     , readPrecompiledCache+    -- Exported for testing+    , BuildCache(..)     ) where -import           Control.Exception.Enclosed (handleIO)+import           Control.DeepSeq (NFData)+import           Control.Exception.Enclosed (handleIO, tryAnyDeep)+import           Control.Monad (liftM) import           Control.Monad.Catch (MonadThrow, MonadCatch) import           Control.Monad.IO.Class import           Control.Monad.Logger (MonadLogger, logDebug)-import           Control.Monad.Reader+import           Control.Monad.Reader (MonadReader, asks)+import           Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256-import qualified Data.Binary as Binary (encode)-import           Data.Binary.VersionTagged-import qualified Data.ByteString.Char8 as S8+import           Data.Binary (Binary (..))+import qualified Data.Binary as Binary+import           Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion)+import qualified Data.Binary.Tagged as BinaryTagged import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Base64.URL as B64URL+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.Monoid ((<>)) 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           GHC.Generics (Generic)+import           Data.Traversable (forM) import           Path import           Path.IO-import           Stack.Types.Build import           Stack.Constants-import           Stack.Types+import           Stack.Types.Build+import           Stack.Types.Compiler+import           Stack.Types.Config+import           Stack.Types.GhcPkgId+import           Stack.Types.Package+import           Stack.Types.PackageIdentifier+import           Stack.Types.Version+import qualified System.FilePath as FilePath  -- | Directory containing files to mark an executable as installed exeInstalledDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m)@@ -62,16 +84,29 @@ getInstalledExes loc = do     dir <- exeInstalledDir loc     (_, files) <- liftIO $ handleIO (const $ return ([], [])) $ listDir dir-    return $ mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files+    return $+        concat $+        M.elems $+        -- If there are multiple install records (from a stack version+        -- before https://github.com/commercialhaskell/stack/issues/2373+        -- was fixed), then we don't know which is correct - ignore them.+        M.fromListWith (\_ _ -> []) $+        map (\x -> (packageIdentifierName x, [x])) $+        mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files  -- | Mark the given executable as installed-markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)+markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadCatch m)                  => InstallLocation -> PackageIdentifier -> m () markExeInstalled loc ident = do     dir <- exeInstalledDir loc     ensureDir dir     ident' <- parseRelFile $ packageIdentifierString ident     let fp = toFilePath $ dir </> ident'+    -- Remove old install records for this package.+    -- TODO: This is a bit in-efficient. Put all this metadata into one file?+    installed <- getInstalledExes loc+    forM_ (filter (\x -> packageIdentifierName ident == packageIdentifierName x) installed)+          (markExeNotInstalled loc)     -- TODO consideration for the future: list all of the executables     -- installed, and invalidate this file in getInstalledExes if they no     -- longer exist@@ -85,66 +120,47 @@     ident' <- parseRelFile $ packageIdentifierString ident     ignoringAbsence (removeFile $ dir </> ident') --- | Stored on disk to know whether the flags have changed or any--- files have changed.-data BuildCache = BuildCache-    { buildCacheTimes :: !(Map FilePath FileCacheInfo)-      -- ^ Modification times of files.-    }-    deriving (Generic)-instance Binary BuildCache-instance HasStructuralInfo BuildCache-instance HasSemanticVersion BuildCache-instance NFData BuildCache- -- | Try to read the dirtiness cache for the given package directory.-tryGetBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env)+tryGetBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, MonadLogger m, HasEnvConfig env, MonadBaseControl IO m)                  => Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo))-tryGetBuildCache = liftM (fmap buildCacheTimes) . tryGetCache buildCacheFile+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)+tryGetConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m)                   => Path Abs Dir -> m (Maybe ConfigCache)-tryGetConfigCache = tryGetCache configCacheFile+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)+tryGetCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m)                => Path Abs Dir -> m (Maybe ModTime)-tryGetCabalMod = tryGetCache configCabalMod---- | Try to load a cache.-tryGetCache :: (MonadIO m, BinarySchema a)-            => (Path Abs Dir -> m (Path Abs File))-            -> Path Abs Dir-            -> m (Maybe a)-tryGetCache get' dir = do-    fp <- get' dir-    decodeFileOrFailDeep fp+tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir  -- | Write the dirtiness cache for this package's files.-writeBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env)+writeBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)                 => Path Abs Dir -> Map FilePath FileCacheInfo -> m ()-writeBuildCache dir times =-    writeCache-        dir-        buildCacheFile-        BuildCache-         { buildCacheTimes = times-         }+writeBuildCache dir times = do+    fp <- buildCacheFile dir+    $(versionedEncodeFile buildCacheVC) fp BuildCache+        { buildCacheTimes = times+        }  -- | Write the dirtiness cache for this package's configuration.-writeConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env)+writeConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)                 => Path Abs Dir                 -> ConfigCache                 -> m ()-writeConfigCache dir = writeCache dir configCacheFile+writeConfigCache dir x = do+    fp <- configCacheFile dir+    $(versionedEncodeFile configCacheVC) fp x  -- | See 'tryGetCabalMod'-writeCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env)+writeCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)               => Path Abs Dir               -> ModTime               -> m ()-writeCabalMod dir = writeCache dir configCabalMod+writeCabalMod dir x = do+    fp <- configCabalMod dir+    $(versionedEncodeFile modTimeVC) fp x  -- | Delete the caches for the project. deleteCaches :: (MonadIO m, MonadReader env m, MonadCatch m, HasEnvConfig env)@@ -157,16 +173,6 @@     cfp <- configCacheFile dir     ignoringAbsence (removeFile cfp) --- | Write to a cache.-writeCache :: (BinarySchema a, MonadIO m)-           => Path Abs Dir-           -> (Path Abs Dir -> m (Path Abs File))-           -> a-           -> m ()-writeCache dir get' content = do-    fp <- get' dir-    taggedEncodeFile fp content- flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)               => Installed               -> m (Path Abs File)@@ -179,51 +185,46 @@     return $ dir </> rel  -- | Loads the flag cache for the given installed extra-deps-tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)+tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m)                 => Installed                 -> m (Maybe ConfigCache) tryGetFlagCache gid = do     fp <- flagCacheFile gid-    decodeFileOrFailDeep fp+    $(versionedDecodeFile configCacheVC) fp -writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)+writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, MonadLogger m)                => Installed                -> ConfigCache                -> m () writeFlagCache gid cache = do     file <- flagCacheFile gid-    liftIO $ do-        ensureDir (parent file)-        taggedEncodeFile file cache+    ensureDir (parent file)+    $(versionedEncodeFile configCacheVC) file cache  -- | Mark a test suite as having succeeded-setTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)+setTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m)                => Path Abs Dir                -> m ()-setTestSuccess dir =-    writeCache-        dir-        testSuccessFile-        True+setTestSuccess dir = do+    fp <- testSuccessFile dir+    $(versionedEncodeFile testSuccessVC) fp True  -- | Mark a test suite as not having succeeded-unsetTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)+unsetTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m)                  => Path Abs Dir                  -> m ()-unsetTestSuccess dir =-    writeCache-        dir-        testSuccessFile-        False+unsetTestSuccess dir = do+    fp <- testSuccessFile dir+    $(versionedEncodeFile testSuccessVC) fp False  -- | Check if the test suite already passed-checkTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)+checkTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m)                  => Path Abs Dir                  -> m Bool checkTestSuccess dir =     liftM         (fromMaybe False)-        (tryGetCache testSuccessFile dir)+        ($(versionedDecodeFile testSuccessVC) =<< testSuccessFile dir)  -------------------------------------- -- Precompiled Cache@@ -236,48 +237,49 @@ -- | The file containing information on the given package/configuration -- combination. The filename contains a hash of the non-directory configure -- options for quick lookup if there's a match.+--+-- It also returns an action yielding the location of the precompiled+-- path based on the old binary encoding.+--+-- We only pay attention to non-directory options. We don't want to avoid a+-- cache hit just because it was installed in a different directory. precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m)                      => PackageIdentifier                      -> ConfigureOpts                      -> Set GhcPkgId -- ^ dependencies-                     -> m (Path Abs File)+                     -> m (Path Abs File, m (Path Abs File)) precompiledCacheFile pkgident copts installedPackageIDs = do     ec <- asks getEnvConfig      compiler <- parseRelDir $ compilerVersionString $ envConfigCompilerVersion ec     cabal <- parseRelDir $ versionString $ envConfigCabalVersion ec     pkg <- parseRelDir $ packageIdentifierString pkgident+    platformRelDir <- platformGhcRelDir +    let input = (coNoDirs copts, installedPackageIDs)+     -- 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. In 20/20-    -- hindsight, we would simply always do that, but previous Stack releases-    -- used only the options, and we don't want to invalidate old caches-    -- unnecessarily.-    --+    -- supplement it with the installed package IDs directly.     -- See issue: https://github.com/commercialhaskell/stack/issues/1103-    let computeCacheSource input = do-            $logDebug $ "Precompiled cache input = " <> T.pack (show input)-            return $ Binary.encode input-    cacheInput <--        if envConfigCabalVersion ec >= $(mkVersion "1.22")-            then computeCacheSource (coNoDirs copts)-            else computeCacheSource (coNoDirs copts, installedPackageIDs)--    -- We only pay attention to non-directory options. We don't want to avoid a-    -- cache hit just because it was installed in a different directory.-    copts' <- parseRelFile $ S8.unpack $ B16.encode $ SHA256.hashlazy cacheInput--    platformRelDir <- platformGhcRelDir+    let oldHash = B16.encode $ SHA256.hash $ LBS.toStrict $+            if envConfigCabalVersion ec >= $(mkVersion "1.22")+                then Binary.encode (coNoDirs copts)+                else Binary.encode input+        hashToPath hash = do+            hashPath <- parseRelFile $ S8.unpack hash+            return $ getStackRoot ec+                 </> $(mkRelDir "precompiled")+                 </> platformRelDir+                 </> compiler+                 </> cabal+                 </> pkg+                 </> hashPath -    return $ getStackRoot ec-         </> $(mkRelDir "precompiled")-         </> platformRelDir-         </> compiler-         </> cabal-         </> pkg-         </> copts'+    $logDebug $ "Precompiled cache input = " <> T.pack (show input)+    newPath <- hashToPath $ B64URL.encode $ SHA256.hash $ Store.encode input+    return (newPath, hashToPath oldHash)  -- | Write out information about a newly built package writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m)@@ -289,29 +291,68 @@                       -> Set Text -- ^ executables                       -> m () writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do-    file <- precompiledCacheFile pkgident copts depIDs+    (file, _) <- precompiledCacheFile pkgident copts depIDs     ensureDir (parent file)+    ec <- asks getEnvConfig+    let stackRootRelative = makeRelative (getStackRoot ec)     mlibpath <-         case mghcPkgId of             Executable _ -> return Nothing             Library _ ipid -> liftM Just $ do                 ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf"-                return $ toFilePath $ bcoSnapDB baseConfigOpts </> ipid'+                relPath <- stackRootRelative $ bcoSnapDB baseConfigOpts </> ipid'+                return $ toFilePath $ relPath     exes' <- forM (Set.toList exes) $ \exe -> do         name <- parseRelFile $ T.unpack exe-        return $ toFilePath $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name-    liftIO $ taggedEncodeFile file PrecompiledCache+        relPath <- stackRootRelative $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name+        return $ toFilePath $ relPath+    $(versionedEncodeFile precompiledCacheVC) file PrecompiledCache         { pcLibrary = mlibpath         , pcExes = exes'         }  -- | Check the cache for a precompiled package matching the given -- configuration.-readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m)+readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m, MonadBaseControl IO m)                      => PackageIdentifier -- ^ target package                      -> ConfigureOpts                      -> Set GhcPkgId -- ^ dependencies                      -> m (Maybe PrecompiledCache) readPrecompiledCache pkgident copts depIDs = do-    file <- precompiledCacheFile pkgident copts depIDs-    decodeFileOrFailDeep file+    ec <- asks getEnvConfig+    let toAbsPath path = do+          if FilePath.isAbsolute path+              then path -- Only older version store absolute path+              else toFilePath (getStackRoot 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 (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 (\_ -> 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)
src/Stack/Build/ConstructPlan.hs view
@@ -1,12 +1,14 @@-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE ViewPatterns          #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-} -- | Construct a @Plan@ for how to build module Stack.Build.ConstructPlan     ( constructPlan@@ -17,7 +19,7 @@ import           Control.Monad import           Control.Monad.Catch (MonadCatch) import           Control.Monad.IO.Class-import           Control.Monad.Logger (MonadLogger, logWarn)+import           Control.Monad.Logger import           Control.Monad.RWS.Strict import           Control.Monad.Trans.Resource import           Data.Either@@ -29,15 +31,19 @@ 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           Generics.Deriving.Monoid (memptydefault, mappenddefault) import           Network.HTTP.Client.Conduit (HasHttpManager)+import           Path import           Prelude hiding (pi, writeFile) import           Stack.Build.Cache import           Stack.Build.Haddock@@ -47,7 +53,16 @@ import           Stack.Package import           Stack.PackageDump import           Stack.PackageIndex-import           Stack.Types+import           Stack.PrettyPrint+import           Stack.Types.Build+import           Stack.Types.Config+import           Stack.Types.FlagName+import           Stack.Types.GhcPkgId+import           Stack.Types.Internal (HasTerminal)+import           Stack.Types.Package+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName+import           Stack.Types.Version  data PackageInfo     = PIOnlyInstalled InstallLocation Installed@@ -78,6 +93,8 @@     | ADRFound InstallLocation Installed     deriving Show +type ParentMap = MonoidMap PackageName (First Version, [(PackageIdentifier, VersionRange)])+ data W = W     { wFinals :: !(Map PackageName (Either ConstructPlanException Task))     , wInstall :: !(Map Text InstallLocation)@@ -88,6 +105,8 @@     -- ^ Packages which count as dependencies     , wWarnings :: !([Text] -> [Text])     -- ^ Warnings+    , wParents :: !ParentMap+    -- ^ Which packages a given package depends on, along with the package's version     } deriving Generic instance Monoid W where     mempty = memptydefault@@ -111,6 +130,7 @@     , getVersions    :: !(PackageName -> IO (Set Version))     , wanted         :: !(Set PackageName)     , localNames     :: !(Set PackageName)+    , logFunc        :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()     }  instance HasStackRoot Ctx@@ -123,7 +143,7 @@     getEnvConfig = ctxEnvConfig  constructPlan :: forall env m.-                 (MonadCatch m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m, MonadBaseControl IO m, HasHttpManager env)+                 (MonadCatch m, MonadReader env m, HasEnvConfig env, MonadLoggerIO m, MonadBaseControl IO m, HasHttpManager env, HasTerminal env)               => MiniBuildPlan               -> BaseConfigOpts               -> [LocalPackage]@@ -134,6 +154,7 @@               -> InstalledMap               -> m Plan constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap = do+    $logDebug "Constructing the build plan"     let locallyRegistered = Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localDumpPkgs     getVersions0 <- getPackageVersionsIO @@ -142,8 +163,9 @@     let inner = do             mapM_ onWanted $ filter lpWanted locals             mapM_ (addDep False) $ Set.toList extraToBuild0-    ((), m, W efinals installExes dirtyReason deps warnings) <--        liftIO $ runRWST inner (ctx econfig getVersions0) M.empty+    lf <- askLoggerIO+    ((), m, W efinals installExes dirtyReason deps warnings parents) <-+        liftIO $ runRWST inner (ctx econfig getVersions0 lf) M.empty     mapM_ $logWarn (warnings [])     let toEither (_, Left e)  = Left e         toEither (k, Right v) = Right (k, v)@@ -169,9 +191,11 @@                         then installExes                         else Map.empty                 }-        else throwM $ ConstructPlanExceptions errs (bcStackYaml $ getBuildConfig econfig)+        else do+            $prettyError $ pprintExceptions errs (bcStackYaml (getBuildConfig econfig)) parents (wantedLocalPackages locals)+            throwM $ ConstructPlanFailed "Plan construction failed."   where-    ctx econfig getVersions0 = Ctx+    ctx econfig getVersions0 lf = Ctx         { mbp = mbp0         , baseConfigOpts = baseConfigOpts0         , loadPackage = loadPackage0@@ -185,6 +209,7 @@         , getVersions = getVersions0         , wanted = wantedLocalPackages locals         , 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@@ -434,17 +459,19 @@                 return (latestApplicableVersion range vs)         case eres of             Left e -> do+                addParent depname range Nothing                 let bd =                         case e of                             UnknownPackage name -> assert (name == depname) NotInBuildPlan-                            _ -> Couldn'tResolveItsDependencies+                            _ -> Couldn'tResolveItsDependencies (packageVersion package)                 mlatestApplicable <- getLatestApplicable                 return $ Left (depname, (range, mlatestApplicable, bd))             Right adr -> do+                addParent depname range Nothing                 inRange <- if adrVersion adr `withinRange` range                     then return True                     else do-                        let warn reason =+                        let warn_ reason =                                 tell mempty { wWarnings = (msg:) }                               where                                 msg = T.concat@@ -460,14 +487,14 @@                         allowNewer <- asks $ configAllowNewer . getConfig                         if allowNewer                             then do-                                warn " (allow-newer enabled)"+                                warn_ " (allow-newer enabled)"                                 return True                             else do                                 x <- inSnapshot (packageName package) (packageVersion package)                                 y <- inSnapshot depname (adrVersion adr)                                 if x && y                                     then do-                                        warn " (trusting snapshot over Hackage revisions)"+                                        warn_ " (trusting snapshot over Hackage revisions)"                                         return True                                     else return False                 if inRange@@ -489,6 +516,9 @@   where     adrVersion (ADRToInstall task) = packageIdentifierVersion $ taskProvides task     adrVersion (ADRFound _ installed) = installedVersion installed+    addParent depname range mversion = tell mempty { wParents = MonoidMap $ M.singleton depname val }+      where+        val = (First mversion, [(packageIdentifier package, range)])  checkDirtiness :: PackageSource                -> Installed@@ -498,7 +528,7 @@                -> M Bool checkDirtiness ps installed package present wanted = do     ctx <- ask-    moldOpts <- tryGetFlagCache installed+    moldOpts <- flip runLoggingT (logFunc ctx) $ tryGetFlagCache installed     let configOpts = configureOpts             (getEnvConfig ctx)             (baseConfigOpts ctx)@@ -689,3 +719,185 @@         guard $ not $ name `Set.member` ls         mpi <- Map.lookup name (mbpPackages p)         return $ mpiVersion mpi == version++data ConstructPlanException+    = DependencyCycleDetected [PackageName]+    | DependencyPlanFailures Package (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency))+    | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all+    -- ^ Recommend adding to extra-deps, give a helpful version number?+    deriving (Typeable, Eq)++-- | For display purposes only, Nothing if package not found+type LatestApplicableVersion = Maybe Version++-- | Reason why a dependency was not used+data BadDependency+    = NotInBuildPlan+    | Couldn'tResolveItsDependencies Version+    | DependencyMismatch Version+    deriving (Typeable, Eq)++-- TODO: Consider intersecting version ranges for multiple deps on a+-- package.  This is why VersionRange is in the parent map.++pprintExceptions+    :: [ConstructPlanException]+    -> Path Abs File+    -> ParentMap+    -> Set PackageName+    -> AnsiDoc+pprintExceptions exceptions stackYaml parentMap wanted =+    line <>+    "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"+  where+    exceptions' = nub exceptions++    extras = Map.unions $ map getExtras exceptions'+    getExtras (DependencyCycleDetected _) = Map.empty+    getExtras (UnknownPackage _) = Map.empty+    getExtras (DependencyPlanFailures _ m) =+       Map.unions $ map go $ Map.toList m+     where+       go (name, (_range, Just version, NotInBuildPlan)) =+           Map.singleton name version+       go _ = Map.empty+    pprintExtra (name, version) =+      fromString (concat ["- ", packageNameString name, "-", versionString version])++    pprintException (DependencyCycleDetected pNames) = Just $ errorRed $+        "Dependency cycle detected in packages:" <> line <>+        indent 4 (encloseSep "[" "]" "," (map (fromString . packageNameString) pNames))+    pprintException (DependencyPlanFailures pkg (Map.toList -> pDeps)) =+        case mapMaybe pprintDep pDeps of+            [] -> Nothing+            depErrors -> Just $+                "In the dependencies for" <+> pkgIdent <>+                pprintFlags (packageFlags pkg) <> ":" <> line <>+                indent 4 (vsep depErrors) <>+                case getShortestDepsPath parentMap wanted (packageName pkg) of+                    [] -> mempty+                    [target,_] -> line <> "needed since" <+> displayTargetPkgId target <+> "is a build target."+                    (target:path) -> line <> "needed due to " <> encloseSep "" "" " -> " pathElems+                      where+                        pathElems =+                            [displayTargetPkgId target] +++                            map display path +++                            [pkgIdent]+              where+                pkgIdent = displayCurrentPkgId (packageIdentifier pkg)+        -- TODO: optionally show these?+    -- Skip these because they are redundant with 'NotInBuildPlan' info.+    pprintException (UnknownPackage _) = Nothing++    pprintFlags flags+        | Map.null flags = ""+        | otherwise = parens $ sep $ map pprintFlag $ Map.toList flags+    pprintFlag (name, True) = "+" <> fromString (show name)+    pprintFlag (name, False) = "-" <> fromString (show name)++    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" <>+                   latestApplicable Nothing)+        -- TODO: For local packages, suggest editing constraints+        DependencyMismatch version -> Just $+            displayErrorPkgId (PackageIdentifier name version) <+>+            align ("must 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+      where+        goodRange = goodGreen (fromString (Cabal.display range))+        latestApplicable mversion =+            case mlatestApplicable of+                Nothing -> ""+                Just la+                    | mlatestApplicable == mversion -> softline <>+                        "(latest applicable is specified)"+                    | otherwise -> softline <>+                        "(latest applicable is " <> goodGreen (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'+-- package.+getShortestDepsPath+    :: ParentMap+    -> Set PackageName+    -> PackageName+    -> [PackageIdentifier]+getShortestDepsPath (MonoidMap parentsMap) wanted name =+    case M.lookup name parentsMap of+        Nothing -> []+        Just (_, parents) -> findShortest 256 paths0+          where+            paths0 = M.fromList $ map (\(ident, _) -> (packageIdentifierName ident, startDepsPath ident)) parents+  where+    -- The 'paths' map is a map from PackageName to the shortest path+    -- found to get there. It is the frontier of our breadth-first+    -- search of dependencies.+    findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier]+    findShortest fuel _ | fuel <= 0 =+        [PackageIdentifier $(mkPackageName "stack-ran-out-of-jet-fuel") $(mkVersion "0")]+    findShortest _ paths | M.null paths = []+    findShortest fuel paths =+        case targets of+            [] -> findShortest (fuel - 1) $ M.fromListWith chooseBest $ concatMap extendPath recurses+            _ -> let (DepsPath _ _ path) = minimum (map snd targets) in path+      where+        (targets, recurses) = partition (\(n, _) -> n `Set.member` wanted) (M.toList paths)+    chooseBest :: DepsPath -> DepsPath -> DepsPath+    chooseBest x y = if x > y then x else y+    -- Extend a path to all its parents.+    extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]+    extendPath (n, dp) =+        case M.lookup n parentsMap of+            Nothing -> []+            Just (_, parents) -> map (\(pkgId, _) -> (packageIdentifierName pkgId, extendDepsPath pkgId dp)) parents++data DepsPath = DepsPath+    { dpLength :: Int -- ^ Length of dpPath+    , dpNameLength :: Int -- ^ Length of package names combined+    , dpPath :: [PackageIdentifier] -- ^ A path where the packages later+                                    -- in the list depend on those that+                                    -- come earlier+    }+    deriving (Eq, Ord, Show)++startDepsPath :: PackageIdentifier -> DepsPath+startDepsPath ident = DepsPath+    { dpLength = 1+    , dpNameLength = T.length (packageNameText (packageIdentifierName ident))+    , dpPath = [ident]+    }++extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath+extendDepsPath ident dp = DepsPath+    { dpLength = dpLength dp + 1+    , dpNameLength = dpNameLength dp + T.length (packageNameText (packageIdentifierName ident))+    , dpPath = [ident]+    }++-- Utility newtype wrapper to make make Map's Monoid also use the+-- element's Monoid.++newtype MonoidMap k a = MonoidMap (Map k a)+    deriving (Eq, Ord, Read, Show, Generic, Functor)++instance (Ord k, Monoid a) => Monoid (MonoidMap k a) where+    mappend (MonoidMap mp1) (MonoidMap mp2) = MonoidMap (M.unionWith mappend mp1 mp2)+    mempty = MonoidMap mempty
src/Stack/Build/Execute.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE LambdaCase            #-} -- | Perform a build module Stack.Build.Execute     ( printPlan@@ -78,7 +79,14 @@ import           Stack.GhcPkg import           Stack.Package import           Stack.PackageDump-import           Stack.Types+import           Stack.Types.GhcPkgId+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.Compiler import           Stack.Types.Internal import           Stack.Types.StackT import qualified System.Directory as D@@ -87,7 +95,7 @@ import qualified System.FilePath as FP import           System.IO import           System.PosixCompat.Files (createLink)-import           System.Process.Log (showProcessArgDebug)+import           System.Process.Log (showProcessArgDebug, withProcessTimeLog) import           System.Process.Read import           System.Process.Run @@ -348,6 +356,7 @@             -> Plan             -> m () executePlan menv boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do+    $logDebug "Executing the build plan"     bopts <- asks (configBuild . getConfig)     withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap targets plan) @@ -453,9 +462,9 @@                     , esStackExe = True                     , esLocaleUtf8 = False                     }-    forM_ (boptsCLIExec boptsCli) $ \(cmd, args) -> do-        $logProcessRun cmd args-        callProcess (Cmd Nothing cmd menv' args)+    forM_ (boptsCLIExec boptsCli) $ \(cmd, args) ->+        $withProcessTimeLog cmd args $+            callProcess (Cmd Nothing cmd menv' args)  -- | Windows can't write over the current executable. Instead, we rename the -- current executable to something else and then do the copy.@@ -1088,23 +1097,39 @@                 writeBuildCache pkgDir $ lpNewBuildCache lp             TTUpstream _ _ _ -> return () +        -- FIXME: only output these if they're in the build plan.++        preBuildTime <- modTime <$> liftIO getCurrentTime+        let postBuildCheck succeeded = do+                warnings <- checkForUnlistedFiles taskType preBuildTime pkgDir+                let hasUnlistedModule = any $ \case+                        UnlistedModulesWarning{} -> True+                        _ -> False+                when (not (null warnings)) $ $logInfo ""+                when (not succeeded && hasUnlistedModule warnings) $ do+                    $logInfo "If the above build failed with a linker error or .so/DLL error, addressing these may help:"+                mapM_ ($logWarn . ("Warning: " <>) . T.pack . show) warnings+         () <- announce ("build" <> annSuffix)         config <- asks getConfig         extraOpts <- extraBuildOptions eeBuildOpts-        preBuildTime <- modTime <$> liftIO getCurrentTime-        cabal (configHideTHLoading config) $ ("build" :) $ (++ extraOpts) $+        (cabal (configHideTHLoading config) $ ("build" :) $ (++ extraOpts) $             case (taskType, taskAllInOne, isFinalBuild) of                 (_, True, True) -> fail "Invariant violated: cannot have an all-in-one build that also has a final build step."                 (TTLocal lp, False, False) -> primaryComponentOptions lp                 (TTLocal lp, False, True) -> finalComponentOptions lp                 (TTLocal lp, True, False) -> primaryComponentOptions lp ++ finalComponentOptions lp-                (TTUpstream{}, _, _) -> []-        checkForUnlistedFiles taskType preBuildTime pkgDir+                (TTUpstream{}, _, _) -> [])+          `catch` \ex -> case ex of+              CabalExitedUnsuccessfully{} -> postBuildCheck False >> throwM ex+              _ -> throwM ex+        postBuildCheck True          when (doHaddock package) $ do             announce "haddock"             sourceFlag <- do-                hyped <- tryProcessStdout Nothing eeEnvOverride "haddock" ["--hyperlinked-source"]+                -- See #2429 for why the temp dir is used+                hyped <- tryProcessStdout (Just eeTempDir) eeEnvOverride "haddock" ["--hyperlinked-source"]                 case hyped of                     -- Fancy crosslinked source                     Right _ -> do@@ -1166,7 +1191,7 @@             _ -> error "singleBuild: invariant violated: multiple results when describing installed package"  -- | Check if any unlisted files have been found, and add them to the build cache.-checkForUnlistedFiles :: M env m => TaskType -> ModTime -> Path Abs Dir -> m ()+checkForUnlistedFiles :: M env m => TaskType -> ModTime -> Path Abs Dir -> m [PackageWarning] checkForUnlistedFiles (TTLocal lp) preBuildTime pkgDir = do     (addBuildCache,warnings) <-         addUnlistedToBuildCache@@ -1174,11 +1199,11 @@             (lpPackage lp)             (lpCabalFile lp)             (lpNewBuildCache lp)-    mapM_ ($logWarn . ("Warning: " <>) . T.pack . show) warnings     unless (null addBuildCache) $         writeBuildCache pkgDir $         Map.unions (lpNewBuildCache lp : addBuildCache)-checkForUnlistedFiles (TTUpstream _ _ _) _ _ = return ()+    return warnings+checkForUnlistedFiles (TTUpstream _ _ _) _ _ = return []  -- | Determine if all of the dependencies given are installed depsPresent :: InstalledMap -> Map PackageName VersionRange -> Bool@@ -1393,12 +1418,16 @@             Nothing -> return bs             Just fp -> return $ fp `T.append` y -    -- | Match the line:column format at the end of lines+    -- | Match the error location format at the end of lines     isValidSuffix = isRight . parseOnly lineCol-    lineCol = char ':' >> (decimal :: Parser Int)-           >> char ':' >> (decimal :: Parser Int)+    lineCol = char ':'+           >> choice+                [ num >> char ':' >> num >> optional (char '-' >> num) >> return ()+                , char '(' >> num >> char ',' >> num >> string ")-(" >> num >> char ',' >> num >> char ')' >> return ()+                ]            >> char ':'            >> return ()+        where num = some digit      -- | Strip @\r@ characters from the byte vector. Used because Windows.     stripCarriageReturn :: Text -> Text
src/Stack/Build/Haddock.hs view
@@ -42,7 +42,13 @@ import           Path.IO import           Prelude import           Stack.PackageDump-import           Stack.Types+import           Stack.Types.GhcPkgId+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName+import           Stack.Types.Config+import           Stack.Types.Build+import           Stack.Types.Package+import           Stack.Types.Compiler import qualified System.FilePath as FP import           System.IO.Error (isDoesNotExistError) import           System.Process.Read@@ -229,7 +235,7 @@                 (Just destDir)                 envOverride                 (haddockExeName wc)-                (toHaddockArgs hdopts +++                (hoAdditionalArgs hdopts ++                  ["--gen-contents", "--gen-index"] ++                  [x | (xs,_,_,_) <- interfaceOpts, x <- xs])   where
src/Stack/Build/Installed.hs view
@@ -13,35 +13,41 @@  import           Control.Applicative import           Control.Monad-import           Control.Monad.Catch          (MonadMask)+import           Control.Monad.Catch (MonadMask) import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.Reader         (MonadReader, asks)+import           Control.Monad.Reader (MonadReader, asks) import           Control.Monad.Trans.Resource import           Data.Conduit-import qualified Data.Conduit.List            as CL+import qualified Data.Conduit.List as CL+import qualified Data.Foldable as F import           Data.Function-import qualified Data.Foldable                as F-import qualified Data.HashSet                 as HashSet+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.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.Maybe.Extra (mapMaybeM) import           Data.Monoid-import qualified Data.Text                    as T-import           Network.HTTP.Client.Conduit  (HasHttpManager)+import qualified Data.Text as T+import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path-import           Prelude                      hiding (FilePath, writeFile)+import           Prelude hiding (FilePath, writeFile) import           Stack.Build.Cache-import           Stack.Types.Build-import           Stack.Types.Version import           Stack.Constants import           Stack.GhcPkg import           Stack.PackageDump-import           Stack.Types+import           Stack.Types.Build+import           Stack.Types.Compiler+import           Stack.Types.Config+import           Stack.Types.GhcPkgId import           Stack.Types.Internal+import           Stack.Types.Package+import           Stack.Types.PackageDump+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName+import           Stack.Types.Version  type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasEnvConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env) @@ -64,6 +70,7 @@                   , [DumpPackage () ()] -- locally installed                   ) getInstalled menv opts sourceMap = do+    $logDebug "Finding out which packages are already installed"     snapDBPath <- packageDatabaseDeps     localDBPath <- packageDatabaseLocal     extraDBPaths <- packageDatabaseExtra
src/Stack/Build/Source.hs view
@@ -15,6 +15,7 @@     , getGhcOptions     , getLocalPackageViews     , parseTargetsFromBuildOpts+    , parseTargetsFromBuildOptsWith     , addUnlistedToBuildCache     , getDefaultPackageConfig     , getPackageConfig@@ -63,7 +64,13 @@ import              Stack.Constants (wiredInPackages) import              Stack.Package import              Stack.PackageIndex (getPackageVersions)-import              Stack.Types+import              Stack.Types.BuildPlan+import              Stack.Types.FlagName+import              Stack.Types.PackageName+import              Stack.Types.Version+import              Stack.Types.Config+import              Stack.Types.Build+import              Stack.Types.Package import qualified    System.Directory as D import              System.FilePath (takeFileName) import              System.IO (withBinaryFile, IOMode (ReadMode))@@ -81,7 +88,7 @@ loadSourceMap needTargets boptsCli = do     bconfig <- asks getBuildConfig     rawLocals <- getLocalPackageViews-    (mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOpts needTargets boptsCli+    (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@@ -147,8 +154,9 @@                 let p = lpPackage lp                  in (packageName p, PSLocal lp)             , extraDeps3-            , flip fmap (mbpPackages mbp) $ \mpi ->-                PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi) (mpiGhcOptions mpi) (mpiGitSHA1 mpi)+            , 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)             ] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages))      return (targets, mbp, locals, nonLocalTargets, sourceMap)@@ -188,12 +196,27 @@             AGOEverything -> True  -- | Use the build options and environment to parse targets.+--+-- If the local packages views are already known, use 'parseTargetsFromBuildOptsWith'+-- instead. parseTargetsFromBuildOpts     :: (MonadIO m, MonadMask m, MonadReader env m, MonadLogger 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+    :: (MonadIO m, MonadMask m, MonadReader env m, MonadLogger 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 <- asks getBuildConfig     mbp0 <-         case bcResolver bconfig of@@ -207,7 +230,6 @@                     , mbpPackages = Map.empty                     }             _ -> return (bcWantedMiniBuildPlan bconfig)-    rawLocals <- getLocalPackageViews     workingDir <- getCurrentDir      let snapshot = mpiVersion <$> mbpPackages mbp0@@ -257,6 +279,7 @@ getLocalPackageViews :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m)                      => m (Map PackageName (LocalPackageView, GenericPackageDescription)) getLocalPackageViews = do+    $logDebug "Parsing the cabal files of the local packages"     econfig <- asks getEnvConfig     locals <- forM (Map.toList $ envConfigPackages econfig) $ \(dir, treatLikeExtraDep) -> do         cabalfp <- findOrGenerateCabalFile dir@@ -312,7 +335,7 @@ -- based on the selected components loadLocalPackage     :: forall m env.-       (MonadReader env m, HasEnvConfig env, MonadMask m, MonadLogger m, MonadIO m)+       (MonadReader env m, HasEnvConfig env, MonadMask m, MonadLogger m, MonadIO m, MonadBaseControl IO m)     => BuildOptsCLI     -> Map PackageName SimpleTarget     -> (PackageName, (LocalPackageView, GenericPackageDescription))
src/Stack/Build/Target.hs view
@@ -39,7 +39,12 @@ import           Path.Extra (rejectMissingDir) import           Path.IO import           Prelude hiding (concat, concatMap) -- Fix redundant import warnings-import           Stack.Types+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName+import           Stack.Types.Version+import           Stack.Types.Config+import           Stack.Types.Build+import           Stack.Types.Package  -- | The name of a component, which applies to executables, test suites, and benchmarks type ComponentName = Text
src/Stack/BuildPlan.hs view
@@ -45,7 +45,7 @@ import           Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256 import           Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings)-import           Data.Binary.VersionTagged (taggedDecodeOrLoad, decodeFileOrFailDeep, taggedEncodeFile)+import           Data.Store.VersionTagged import qualified Data.ByteString as S import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString.Char8 as S8@@ -66,7 +66,7 @@ import           Data.Text.Encoding (encodeUtf8) import qualified Data.Traversable as Tr import           Data.Typeable (Typeable)-import           Data.Yaml (decodeEither', decodeFileEither)+import           Data.Yaml.Extra (decodeEither', decodeFileEither) import qualified Distribution.Package as C import           Distribution.PackageDescription (GenericPackageDescription,                                                   flagDefault, flagManual,@@ -76,9 +76,7 @@ import           Distribution.System (Platform) import           Distribution.Text (display) import qualified Distribution.Version as C-import           Network.HTTP.Client (checkStatus) import           Network.HTTP.Download-import           Network.HTTP.Types (Status(..)) import           Path import           Path.IO import           Prelude -- Fix AMP warning@@ -86,7 +84,15 @@ import           Stack.Fetch import           Stack.Package import           Stack.PackageIndex-import           Stack.Types+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.StackT  data BuildPlanException@@ -446,7 +452,7 @@     -> m MiniBuildPlan loadMiniBuildPlan name = do     path <- configMiniBuildPlanCache name-    taggedDecodeOrLoad path $ liftM buildPlanFixes $ do+    $(versionedDecodeOrLoad miniBuildPlanVC) path $ liftM buildPlanFixes $ do         bp <- loadBuildPlan name         toMiniBuildPlan             (siCompilerVersion $ bpSystemInfo bp)@@ -498,17 +504,15 @@             $logDebug $ "Decoding build plan from file failed: " <> T.pack (show e)             ensureDir (parent fp)             url <- buildBuildPlanUrl name file-            req <- parseUrl $ T.unpack url+            req <- parseRequest $ T.unpack url             $logSticky $ "Downloading " <> renderSnapName name <> " build plan ..."             $logDebug $ "Downloading build plan from: " <> url-            _ <- redownload req { checkStatus = handle404 } fp+            _ <- redownload req fp             $logStickyDone $ "Downloaded " <> renderSnapName name <> " build plan."             liftIO (decodeFileEither $ toFilePath fp) >>= either throwM return    where     file = renderSnapName name <> ".yaml"-    handle404 (Status 404 _) _ _ = Just $ SomeException $ SnapshotNotFound name-    handle404 _ _ _              = Nothing  buildBuildPlanUrl :: (MonadReader env m, HasConfig env) => SnapName -> Text -> m Text buildBuildPlanUrl name file = do@@ -959,7 +963,7 @@     -> m (MiniBuildPlan, SnapshotHash) parseCustomMiniBuildPlan mconfigPath0 url0 = do     $logDebug $ "Loading " <> url0 <> " build plan"-    case parseUrl $ T.unpack url0 of+    case parseUrlThrow $ T.unpack url0 of         Just req -> downloadCustom url0 req         Nothing ->            case mconfigPath0 of@@ -975,7 +979,7 @@                    -- cases.                    binaryPath <- getBinaryPath hash                    alreadyCached <- doesFileExist binaryPath-                   unless alreadyCached $ taggedEncodeFile binaryPath mbp+                   unless alreadyCached $ $(versionedEncodeFile miniBuildPlanVC) binaryPath mbp                    return (mbp, hash)   where     downloadCustom url req = do@@ -987,7 +991,7 @@         yamlBS <- liftIO $ S.readFile $ toFilePath cacheFP         let yamlHash = doHash yamlBS         binaryPath <- getBinaryPath yamlHash-        liftM (, yamlHash) $ taggedDecodeOrLoad binaryPath $ do+        liftM (, yamlHash) $ $(versionedDecodeOrLoad miniBuildPlanVC) binaryPath $ do             (cs, mresolver) <- decodeYaml yamlBS             parentMbp <- case (csCompilerVersion cs, mresolver) of                 (Nothing, Nothing) -> throwM (NeitherCompilerOrResolverSpecified url)@@ -1004,7 +1008,7 @@         (cs, mresolver) <- decodeYaml yamlBS         (getMbp, hash) <- case mresolver of             Just (ResolverCustom _ url ) ->-                case parseUrl $ T.unpack url of+                case parseUrlThrow $ T.unpack url of                     Just req -> do                         let getMbp = do                                 -- Ignore custom hash, under the@@ -1024,11 +1028,11 @@                                 exists <- doesFileExist binaryPath                                 if exists                                     then do-                                        eres <- decodeFileOrFailDeep binaryPath+                                        eres <- $(versionedDecodeFile miniBuildPlanVC) binaryPath                                         case eres of-                                            Right (Just mbp) -> return mbp+                                            Just mbp -> return mbp                                             -- Invalid format cache file, remove.-                                            _ -> do+                                            Nothing -> do                                                 removeFile binaryPath                                                 getMbp0                                     else getMbp0
src/Stack/Clean.hs view
@@ -22,7 +22,8 @@ import           Stack.Build.Source (getLocalPackageViews) import           Stack.Build.Target (LocalPackageView(..)) import           Stack.Constants (distDirFromDir, workDirFromDir)-import           Stack.Types+import           Stack.Types.PackageName+import           Stack.Types.Config  -- | Deletes build artifacts in the current project. --
src/Stack/Config.hs view
@@ -29,7 +29,6 @@   ,packagesParser   ,resolvePackageEntry   ,getImplicitGlobalProjectDir-  ,getIsGMP4   ,getSnapshots   ,makeConcreteResolver   ,checkOwnership@@ -43,7 +42,7 @@ import           Control.Arrow ((***)) import           Control.Exception (assert) import           Control.Monad (liftM, unless, when, filterM)-import           Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask, catchAll, throwM, catch)+import           Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask, catchAll, throwM, catch, handle) import           Control.Monad.Extra (firstJustM) import           Control.Monad.IO.Class import           Control.Monad.Logger hiding (Loc)@@ -55,20 +54,19 @@ import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString.Lazy as L import           Data.Foldable (forM_)-import qualified Data.IntMap as IntMap import           Data.IORef (newIORef)+import qualified Data.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, decodeUtf8With)-import           Data.Text.Encoding.Error (lenientDecode)-import qualified Data.Yaml as Yaml+import           Data.Text.Encoding (encodeUtf8, decodeUtf8)+import qualified Data.Yaml.Extra as Yaml import           Distribution.System (OS (..), Platform (..), buildPlatform) import qualified Distribution.Text import           Distribution.Version (simplifyVersionRange) import           GHC.Conc (getNumProcessors)-import           Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrl)+import           Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrlThrow) import           Network.HTTP.Download (download, downloadJSON) import           Options.Applicative (Parser, strOption, long, help) import           Path@@ -76,21 +74,26 @@ import           Path.Find (findInParents) import           Path.IO import qualified Paths_stack as Meta-import           Safe (headMay) import           Stack.BuildPlan import           Stack.Config.Build-import           Stack.Config.Urls import           Stack.Config.Docker import           Stack.Config.Nix+import           Stack.Config.Urls import           Stack.Constants import qualified Stack.Image as Image-import           Stack.Types+import           Stack.Types.Config+import           Stack.Types.BuildPlan+import           Stack.Types.Docker+import           Stack.Types.Compiler import           Stack.Types.Internal+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.@@ -142,7 +145,7 @@              => m Snapshots getSnapshots = do     latestUrlText <- askLatestSnapshotUrl-    latestUrl <- parseUrl (T.unpack latestUrlText)+    latestUrl <- parseUrlThrow (T.unpack latestUrlText)     $logDebug $ "Downloading snapshot versions file from " <> latestUrlText     result <- downloadJSON latestUrl     $logDebug $ "Done downloading and parsing snapshot versions file"@@ -201,7 +204,7 @@     -> ConfigMonoid     -> m Config configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject ConfigMonoid{..} = do-     configWorkDir <- parseRelDir (fromFirst ".stack-work" configMonoidWorkDir)+     let configWorkDir = fromFirst $(mkRelDir ".stack-work") configMonoidWorkDir      -- This code is to handle the deprecation of latest-snapshot-url      configUrls <- case (getFirst configMonoidLatestSnapshotUrl, getFirst (urlsMonoidLatestSnapshot configMonoidUrls)) of          (Just url, Nothing) -> do@@ -231,14 +234,14 @@           configExtraIncludeDirs = configMonoidExtraIncludeDirs          configExtraLibDirs = configMonoidExtraLibDirs+         configOverrideGccPath = getFirst configMonoidOverrideGccPath           -- Only place in the codebase where platform is hard-coded. In theory          -- in the future, allow it to be configured.          (Platform defArch defOS) = buildPlatform          arch = fromMaybe defArch               $ (getFirst configMonoidArch) >>= Distribution.Text.simpleParse-         os = fromMaybe defOS-            $ (getFirst configMonoidOS) >>= Distribution.Text.simpleParse+         os = defOS          configPlatform = Platform arch os           configRequireStackVersion = simplifyVersionRange (getIntersectingVersionRange configMonoidRequireStackVersion)@@ -256,7 +259,7 @@      configNix <- nixOptsFromMonoid configMonoidNixOpts os       rawEnv <- liftIO getEnvironment-     pathsEnv <- augmentPathMap (map toFilePath configMonoidExtraPath)+     pathsEnv <- augmentPathMap configMonoidExtraPath                                 (Map.fromList (map (T.pack *** T.pack) rawEnv))      origEnv <- mkEnvOverride configPlatform pathsEnv      let configEnvOverride _ = return origEnv@@ -318,35 +321,6 @@       return Config {..} --- | Get the default 'GHCVariant'.  On older Linux systems with libgmp4, returns 'GHCGMP4'.-getDefaultGHCVariant-    :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)-    => EnvOverride -> Platform -> m GHCVariant-getDefaultGHCVariant menv (Platform _ Linux) = do-    $logDebug "Checking whether stack was built with libgmp4"-    isGMP4 <- getIsGMP4 menv-    if isGMP4-        then $logDebug "Stack was built with libgmp4, so the default ghc-variant will be gmp4"-        else $logDebug "Stack was not built with libgmp4"-    return (if isGMP4 then GHCGMP4 else GHCStandard)-getDefaultGHCVariant _ _ = return GHCStandard---- Determine whether 'stack' is linked with libgmp4 (libgmp.so.3)-getIsGMP4-    :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)-    => EnvOverride -> m Bool-getIsGMP4 menv = do-    executablePath <- liftIO getExecutablePath-    elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath]-    return $-        case elddOut of-            Left _ -> False-            Right lddOut -> hasLineWithFirstWord "libgmp.so.3" lddOut-  where-    hasLineWithFirstWord w =-        elem (Just w) .-        map (headMay . T.words) . T.lines . decodeUtf8With lenientDecode- -- | Get the directory on Windows where we should install extra programs. For -- more information, see discussion at: -- https://github.com/fpco/minghc/issues/43#issuecomment-99737383@@ -374,14 +348,10 @@  -- | Load the 'MiniConfig'. loadMiniConfig-    :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)+    :: (MonadIO m)     => Manager -> Config -> m MiniConfig loadMiniConfig manager config = do-    menv <- liftIO $ configEnvOverride config minimalEnvSettings-    ghcVariant <--        case configGHCVariant0 config of-            Just ghcVariant -> return ghcVariant-            Nothing -> getDefaultGHCVariant menv (configPlatform config)+    let ghcVariant = fromMaybe GHCStandard (configGHCVariant0 config)     return (MiniConfig manager ghcVariant config)  -- Load the configuration, using environment variables, and defaults as@@ -598,21 +568,32 @@     exists <- doesDirExist dir     let cloneAndExtract commandName cloneArgs resetCommand commit = do             ensureDir (parent dir)-            (if exists then doReset True else doClone >> doReset True) `catch` \case-                ReadProcessException{} -> do-                    ignoringAbsence (removeDirRecur dir)+            if exists+                then handleError (doReset True)+                else do                     doClone                     doReset False-                _ -> return ()             return dir           where+            handleError = handle $ \case+                ReadProcessException{} -> do+                    $logInfo $ "Failed to reset to commit " <> commit <> ", deleting and re-cloning."+                    ignoringAbsence (removeDirRecur dir)+                    doClone+                    doReset False+                err -> throwM err             doClone =-                readProcessNull (Just (parent dir)) menv commandName-                    ("clone" :-                    cloneArgs ++-                    [ T.unpack url-                    , toFilePathNoTrailingSep dir-                    ])+                callProcessInheritStderrStdout Cmd+                    { cmdDirectoryToRunIn = Just (parent dir)+                    , cmdCommandToRun = commandName+                    , cmdEnvOverride = menv+                    , cmdCommandLineArguments =+                        ("clone" :+                        cloneArgs +++                        [ T.unpack url+                        , toFilePathNoTrailingSep dir+                        ])+                    }             doReset firstTry =                 readProcessNull (Just dir) menv commandName                     (resetCommand ++ [T.unpack commit, "--"])@@ -629,7 +610,7 @@                 ignoringAbsence (removeDirRecur dirTmp)                  let fp = toFilePath file-                req <- parseUrl $ T.unpack url+                req <- parseUrlThrow $ T.unpack url                 _ <- download req file                  let tryTar = do
src/Stack/Config/Build.hs view
@@ -4,7 +4,7 @@ module Stack.Config.Build where  import           Data.Monoid.Extra-import           Stack.Types+import           Stack.Types.Config  -- | Interprets BuildOptsMonoid options. buildOptsFromMonoid :: BuildOptsMonoid -> BuildOpts@@ -54,7 +54,7 @@ haddockOptsFromMonoid :: HaddockOptsMonoid -> HaddockOpts haddockOptsFromMonoid HaddockOptsMonoid{..} =     defaultHaddockOpts-    {toHaddockArgs = toMonoidHaddockArgs}+    {hoAdditionalArgs = hoMonoidAdditionalArgs}  testOptsFromMonoid :: TestOptsMonoid -> TestOpts testOptsFromMonoid TestOptsMonoid{..} =
src/Stack/Config/Docker.hs view
@@ -4,8 +4,7 @@ module Stack.Config.Docker where  import Control.Exception.Lifted-import Control.Monad-import Control.Monad.Catch (throwM, MonadThrow)+import Control.Monad.Catch (MonadThrow) import Data.List (find) import Data.Maybe import Data.Monoid.Extra@@ -13,7 +12,10 @@ import Data.Typeable (Typeable) import Distribution.Version (simplifyVersionRange) import Path-import Stack.Types+import Stack.Types.BuildPlan+import Stack.Types.Version+import Stack.Types.Config+import Stack.Types.Docker  -- | Interprets DockerOptsMonoid options. dockerOptsFromMonoid@@ -73,17 +75,8 @@         dockerSetUser = getFirst dockerMonoidSetUser         dockerRequireDockerVersion =             simplifyVersionRange (getIntersectingVersionRange dockerMonoidRequireDockerVersion)-    dockerDatabasePath <--        case getFirst dockerMonoidDatabasePath of-            Nothing -> return $ stackRoot </> $(mkRelFile "docker.db")-            Just fp ->-                case parseAbsFile fp of-                    Left e -> throwM (InvalidDatabasePathException e)-                    Right p -> return p-    dockerStackExe <--        case getFirst dockerMonoidStackExe of-            Just e -> liftM Just (parseDockerStackExe e)-            Nothing -> return Nothing+        dockerDatabasePath = fromFirst (stackRoot </> $(mkRelFile "docker.db")) dockerMonoidDatabasePath+        dockerStackExe = getFirst dockerMonoidStackExe     return DockerOpts{..}   where emptyToNothing Nothing = Nothing         emptyToNothing (Just s) | null s = Nothing
src/Stack/Config/Nix.hs view
@@ -7,14 +7,15 @@        ,StackNixException(..)        ) where -import Control.Applicative-import Control.Monad (join, when)+import Control.Monad (when) import Data.Maybe import Data.Monoid.Extra import qualified Data.Text as T import Data.Typeable import Distribution.System (OS (..))-import Stack.Types+import Stack.Types.Version+import Stack.Types.Nix+import Stack.Types.Compiler import Control.Exception.Lifted import Control.Monad.Catch (throwM,MonadCatch) import Prelude@@ -41,13 +42,9 @@   where prefixAll p (x:xs) = p : x : prefixAll p xs         prefixAll _ _      = [] -nixCompiler :: Config -> Maybe Resolver -> Maybe CompilerVersion -> T.Text-nixCompiler config resolverOverride compilerOverride =-  let mproject = fst <$> configMaybeProject config-      mresolver = resolverOverride <|> fmap projectResolver mproject-      mcompiler = compilerOverride <|> join (fmap projectCompiler mproject)--      -- These are the latest minor versions for each respective major version available in nixpkgs+nixCompiler :: CompilerVersion -> 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 "7.10" = "7.10.3"       fixMinor "7.8" = "7.8.4"@@ -57,13 +54,12 @@       fixMinor "6.12" = "6.12.3"       fixMinor "6.10" = "6.10.4"       fixMinor v = v-      nixCompilerFromVersion v = T.append (T.pack "haskell.compiler.ghc") (T.filter (/= '.') (fixMinor (versionText v)))-  in case (mresolver, mcompiler)  of-       (_, Just (GhcVersion v)) -> nixCompilerFromVersion v-       (Just (ResolverCompiler (GhcVersion v)), _) -> nixCompilerFromVersion v-       (Just (ResolverSnapshot (LTS x y)), _) ->-         T.pack ("haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc")-       _ -> T.pack "ghc"+      nixCompilerFromVersion v = T.append (T.pack "haskell.compiler.ghc")+                                          (T.filter (/= '.')+                                             (fixMinor (versionText v)))+  in case compilerVersion of+       GhcVersion v -> nixCompilerFromVersion v+       _ -> error "Only GHC is supported by now by stack --nix"  -- Exceptions thown specifically by Stack.Nix data StackNixException
src/Stack/Config/Urls.hs view
@@ -2,7 +2,7 @@  module Stack.Config.Urls (urlsFromMonoid) where -import           Stack.Types+import           Stack.Types.Urls import           Data.Monoid.Extra  urlsFromMonoid :: UrlsMonoid -> Urls
src/Stack/ConfigCmd.hs view
@@ -17,12 +17,13 @@ import           Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.ByteString as S import qualified Data.HashMap.Strict as HMap-import qualified Data.Yaml as Yaml+import qualified Data.Yaml.Extra as Yaml import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path import           Stack.BuildPlan import           Stack.Config (makeConcreteResolver)-import           Stack.Types+import           Stack.Types.BuildPlan+import           Stack.Types.Config  data ConfigCmdSet = ConfigCmdSetResolver AbstractResolver
+ src/Stack/Constants.hs-boot view
@@ -0,0 +1,3 @@+module Stack.Constants where++stackProgName :: String
src/Stack/Coverage.hs view
@@ -17,8 +17,9 @@     ) where  import           Control.Applicative+import           Control.Exception.Enclosed (handleIO) import           Control.Exception.Lifted-import           Control.Monad (liftM, when, unless, void)+import           Control.Monad (liftM, when, unless, void, (<=<)) import           Control.Monad.Catch (MonadMask) import           Control.Monad.IO.Class import           Control.Monad.Logger@@ -46,7 +47,12 @@ import           Stack.Build.Target import           Stack.Constants import           Stack.Package-import           Stack.Types+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName+import           Stack.Types.Version+import           Stack.Types.Config+import           Stack.Types.Package+import           Stack.Types.Compiler import           System.FilePath (isPathSeparator) import           System.Process.Read import           Text.Hastache (htmlEscape)@@ -76,6 +82,10 @@             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)  -- | Get the directory used for hpc reports for the given pkgId.@@ -99,26 +109,29 @@ generateHpcReport :: (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env)                   => Path Abs Dir -> Package -> [Text] -> m () generateHpcReport pkgDir package tests = do+    compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig)     -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See     -- https://github.com/commercialhaskell/stack/issues/785     let pkgName = packageNameText (packageName package)         pkgId = packageIdentifierString (packageIdentifier package)-    compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig)+        ghcVersion = getGhcVersion compilerVersion     eincludeName <-         -- Pre-7.8 uses plain PKG-version in tix files.-        if getGhcVersion compilerVersion < $(mkVersion "7.10") then return $ Right $ Just pkgId+        if ghcVersion < $(mkVersion "7.10") then return $ Right $ Just pkgId         -- We don't expect to find a package key if there is no library.         else if not (packageHasLibrary package) 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-            mghcPkgKey <- findPackageKeyForBuiltPackage pkgDir (packageIdentifier package)-            case mghcPkgKey of-                Nothing -> do-                    let msg = "Failed to find GHC package key for " <> pkgName-                    $logError msg-                    return $ Left msg-                Just ghcPkgKey -> return $ Right $ Just $ T.unpack ghcPkgKey+            -- GHC 8.0 uses package id instead of package key.+            -- See https://github.com/commercialhaskell/stack/issues/2424+            let hpcNameField = if ghcVersion >= $(mkVersion "8.0") then "id" else "key"+            eincludeName <- findPackageFieldForBuiltPackage pkgDir (packageIdentifier package) hpcNameField+            case eincludeName of+                Left err -> do+                    $logError err+                    return $ Left err+                Right includeName -> return $ Right $ Just $ T.unpack includeName     forM_ tests $ \testName -> do         tixSrc <- tixFilePath (packageName package) (T.unpack testName)         let report = "coverage report for " <> pkgName <> "'s test-suite \"" <> testName <> "\""@@ -198,6 +211,7 @@                         : (args ++ extraMarkupArgs)                         ) + data HpcReportOpts = HpcReportOpts     { hroptsInputs :: [Text]     , hroptsAll :: Bool@@ -390,15 +404,32 @@ dirnameString :: Path r Dir -> String dirnameString = dropWhileEnd isPathSeparator . toFilePath . dirname -findPackageKeyForBuiltPackage :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env)-                              => Path Abs Dir -> PackageIdentifier -> m (Maybe Text)-findPackageKeyForBuiltPackage pkgDir pkgId = do+findPackageFieldForBuiltPackage :: (MonadIO m,MonadBaseControl IO m,MonadReader env m,MonadThrow m,MonadLogger m,HasEnvConfig env) => Path Abs Dir -> PackageIdentifier -> Text -> m (Either Text Text)+findPackageFieldForBuiltPackage pkgDir pkgId field = do     distDir <- distDirFromDir pkgDir-    path <- liftM (distDir </>) $-        parseRelFile ("package.conf.inplace/" ++ packageIdentifierString pkgId ++ "-inplace.conf")-    exists <- doesFileExist path-    if exists-        then do+    let inplaceDir = distDir </> $(mkRelDir "package.conf.inplace")+        pkgIdStr = packageIdentifierString pkgId+        notFoundErr = return $ Left $ "Failed to find package key for " <> T.pack pkgIdStr+        extractField path = do             contents <- liftIO $ T.readFile (toFilePath path)-            return $ asum (map (T.stripPrefix "key: ") (T.lines contents))-        else return Nothing+            case asum (map (T.stripPrefix (field <> ": ")) (T.lines contents)) of+                Just result -> return $ Right result+                Nothing -> notFoundErr+    cabalVer <- asks (envConfigCabalVersion . getEnvConfig)+    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)+            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+            (_, files) <- handleIO (const $ return ([], [])) $ listDir inplaceDir+            $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+                [path] -> extractField path+                _ -> return $ Left $ "Multiple files matching " <> T.pack (pkgIdStr ++ "-*.conf") <> " found in " <>+                    T.pack (toFilePath inplaceDir) <> ". Maybe try 'stack clean' on this package?"
src/Stack/Docker.hs view
@@ -48,10 +48,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import           Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..))-import           Data.Typeable (Typeable) import           Data.Version (showVersion)-import           Distribution.System (Platform (Platform),Arch (X86_64),OS (Linux))-import           Distribution.Text (display) import           GHC.Exts (sortWith) import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path@@ -62,7 +59,10 @@ import           Stack.Config (getInContainer) import           Stack.Constants import           Stack.Docker.GlobalDB-import           Stack.Types+import           Stack.Types.PackageIndex+import           Stack.Types.Version+import           Stack.Types.Config+import           Stack.Types.Docker import           Stack.Types.Internal import           Stack.Setup (ensureDockerStackExe) import           System.Directory (canonicalizePath,getHomeDirectory)@@ -297,10 +297,10 @@                          -- This is fixed in Docker 1.9.1, but will leave the workaround                          -- in place for now, for users who haven't upgraded yet.                          (isTerm || (isNothing bamboo && isNothing jenkins))+     hostBinDirPath <- parseAbsDir hostBinDir      newPathEnv <- augmentPath-                      [ hostBinDir-                      , toFilePathNoTrailingSep $ sandboxHomeDir-                                            </> $(mkRelDir ".local/bin")]+                      [ hostBinDirPath+                      , sandboxHomeDir </> $(mkRelDir ".local/bin")]                       (T.pack <$> lookupImageEnv "PATH" imageEnvVars)      (cmnd,args,envVars,extraMount) <- getCmdArgs docker envOverride imageInfo isRemoteDocker      pwd <- getCurrentDir@@ -882,29 +882,6 @@ oldSandboxIdEnvVar :: String oldSandboxIdEnvVar = "DOCKER_SANDBOX_ID" --- | Command-line argument for "docker"-dockerCmdName :: String-dockerCmdName = "docker"--dockerHelpOptName :: String-dockerHelpOptName = dockerCmdName ++ "-help"---- | Command-line argument for @docker pull@.-dockerPullCmdName :: String-dockerPullCmdName = "pull"---- | Command-line argument for @docker cleanup@.-dockerCleanupCmdName :: String-dockerCleanupCmdName = "cleanup"---- | Command-line option for @--internal-re-exec-version@.-reExecArgName :: String-reExecArgName = "internal-re-exec-version"---- | Platform that Docker containers run-dockerContainerPlatform :: Platform-dockerContainerPlatform = Platform X86_64 Linux- -- | Options for 'cleanup'. data CleanupOpts = CleanupOpts   { dcAction                                :: !CleanupAction@@ -951,135 +928,6 @@        ImageConfig          <$> fmap join (o .:? "Env") .!= []          <*> fmap join (o .:? "Entrypoint") .!= []---- | Exceptions thrown by Stack.Docker.-data StackDockerException-  = DockerMustBeEnabledException-    -- ^ Docker must be enabled to use the command.-  | OnlyOnHostException-    -- ^ Command must be run on host OS (not in a container).-  | InspectFailedException String-    -- ^ @docker inspect@ failed.-  | NotPulledException String-    -- ^ Image does not exist.-  | InvalidCleanupCommandException String-    -- ^ Input to @docker cleanup@ has invalid command.-  | InvalidImagesOutputException String-    -- ^ Invalid output from @docker images@.-  | InvalidPSOutputException String-    -- ^ Invalid output from @docker ps@.-  | InvalidInspectOutputException String-    -- ^ Invalid output from @docker inspect@.-  | PullFailedException String-    -- ^ Could not pull a Docker image.-  | DockerTooOldException Version Version-    -- ^ Installed version of @docker@ below minimum version.-  | DockerVersionProhibitedException [Version] Version-    -- ^ Installed version of @docker@ is prohibited.-  | BadDockerVersionException VersionRange Version-    -- ^ Installed version of @docker@ is out of range specified in config file.-  | InvalidVersionOutputException-    -- ^ Invalid output from @docker --version@.-  | HostStackTooOldException Version (Maybe Version)-    -- ^ Version of @stack@ on host is too old for version in image.-  | ContainerStackTooOldException Version Version-    -- ^ Version of @stack@ in container/image is too old for version on host.-  | CannotDetermineProjectRootException-    -- ^ Can't determine the project root (where to put docker sandbox).-  | DockerNotInstalledException-    -- ^ @docker --version@ failed.-  | UnsupportedStackExeHostPlatformException-    -- ^ Using host stack-exe on unsupported platform.-  deriving (Typeable)---- | Exception instance for StackDockerException.-instance Exception StackDockerException---- | Show instance for StackDockerException.-instance Show StackDockerException where-  show DockerMustBeEnabledException =-    "Docker must be enabled in your configuration file to use this command."-  show OnlyOnHostException =-    "This command must be run on host OS (not in a Docker container)."-  show (InspectFailedException image) =-    concat ["'docker inspect' failed for image after pull: ",image,"."]-  show (NotPulledException image) =-    concat ["The Docker image referenced by your configuration file"-           ," has not\nbeen downloaded:\n    "-           ,image-           ,"\n\nRun '"-           ,unwords [stackProgName, dockerCmdName, dockerPullCmdName]-           ,"' to download it, then try again."]-  show (InvalidCleanupCommandException line) =-    concat ["Invalid line in cleanup commands: '",line,"'."]-  show (InvalidImagesOutputException line) =-    concat ["Invalid 'docker images' output line: '",line,"'."]-  show (InvalidPSOutputException line) =-    concat ["Invalid 'docker ps' output line: '",line,"'."]-  show (InvalidInspectOutputException msg) =-    concat ["Invalid 'docker inspect' output: ",msg,"."]-  show (PullFailedException image) =-    concat ["Could not pull Docker image:\n    "-           ,image-           ,"\nThere may not be an image on the registry for your resolver's LTS version in\n"-           ,"your configuration file."]-  show (DockerTooOldException minVersion haveVersion) =-    concat ["Minimum docker version '"-           ,versionString minVersion-           ,"' is required by "-           ,stackProgName-           ," (you have '"-           ,versionString haveVersion-           ,"')."]-  show (DockerVersionProhibitedException prohibitedVersions haveVersion) =-    concat ["These Docker versions are incompatible with "-           ,stackProgName-           ," (you have '"-           ,versionString haveVersion-           ,"'): "-           ,intercalate ", " (map versionString prohibitedVersions)-           ,"."]-  show (BadDockerVersionException requiredRange haveVersion) =-    concat ["The version of 'docker' you are using ("-           ,show haveVersion-           ,") is outside the required\n"-           ,"version range specified in stack.yaml ("-           ,T.unpack (versionRangeText requiredRange)-           ,")."]-  show InvalidVersionOutputException =-    "Cannot get Docker version (invalid 'docker --version' output)."-  show (HostStackTooOldException minVersion (Just hostVersion)) =-    concat ["The host's version of '"-           ,stackProgName-           ,"' is too old for this Docker image.\nVersion "-           ,versionString minVersion-           ," is required; you have "-           ,versionString hostVersion-           ,"."]-  show (HostStackTooOldException minVersion Nothing) =-    concat ["The host's version of '"-           ,stackProgName-           ,"' is too old.\nVersion "-           ,versionString minVersion-           ," is required."]-  show (ContainerStackTooOldException requiredVersion containerVersion) =-    concat ["The Docker container's version of '"-           ,stackProgName-           ,"' is too old.\nVersion "-           ,versionString requiredVersion-           ," is required; the container has "-           ,versionString containerVersion-           ,"."]-  show CannotDetermineProjectRootException =-    "Cannot determine project root directory for Docker sandbox."-  show DockerNotInstalledException =-    "Cannot find 'docker' in PATH.  Is Docker installed?"-  show UnsupportedStackExeHostPlatformException = concat-    [ "Using host's "-    , stackProgName-    , " executable in Docker container is only supported on "-    , display dockerContainerPlatform-    , " platform" ]  -- | Function to get command and arguments to run in Docker container type GetCmdArgs env m
src/Stack/Dot.hs view
@@ -36,7 +36,12 @@ import           Stack.Build.Target import           Stack.Constants import           Stack.Package-import           Stack.Types+import           Stack.Types.FlagName+import           Stack.Types.PackageName+import           Stack.Types.Version+import           Stack.Types.Config+import           Stack.Types.Build+import           Stack.Types.Package import           Stack.Types.Internal (HasLogLevel)  -- | Options record for @stack dot@
src/Stack/Exec.hs view
@@ -15,13 +15,13 @@ import           Control.Monad.Reader import           Control.Monad.Logger import           Control.Monad.Trans.Control (MonadBaseControl)-import           Stack.Types+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, Cmd(..))+import           System.Process.Run (callProcess, callProcessObserveStdout, Cmd(..)) #ifdef WINDOWS import           System.Process.Read (EnvOverride) #else@@ -61,9 +61,9 @@ exec = execSpawn #else exec menv cmd0 args = do-    $logProcessRun cmd0 args     cmd <- preProcess Nothing menv cmd0-    liftIO $ executeFile cmd True args (envHelper menv)+    $withProcessTimeLog cmd args $+        liftIO $ executeFile cmd True args (envHelper menv) #endif  -- | Like 'exec', but does not use 'execv' on non-windows. This way, there@@ -73,8 +73,17 @@ execSpawn :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)      => EnvOverride -> String -> [String] -> m b execSpawn menv cmd0 args = do-    $logProcessRun cmd0 args-    e <- try (callProcess (Cmd Nothing cmd0 menv 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)+    => EnvOverride -> String -> [String] -> m String+execObserve menv cmd0 args = do+    e <- $withProcessTimeLog cmd0 args $+        try (callProcessObserveStdout (Cmd Nothing cmd0 menv args))+    case e of+        Left (ProcessExitedUnsuccessfully _ ec) -> liftIO $ exitWith ec+        Right s -> return s
src/Stack/Fetch.hs view
@@ -16,6 +16,7 @@     ( unpackPackages     , unpackPackageIdents     , fetchPackages+    , untar     , resolvePackages     , resolvePackagesAllowMissing     , ResolvedPackage (..)@@ -70,12 +71,17 @@ import           Data.Word                      (Word64) import           Network.HTTP.Download import           Path+import           Path.Extra (toFilePathNoTrailingSep) import           Path.IO import           Prelude -- Fix AMP warning import           Stack.GhcPkg import           Stack.PackageIndex-import           Stack.Types-import qualified System.Directory               as D+import           Stack.Types.BuildPlan+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageIndex+import           Stack.Types.PackageName+import           Stack.Types.Version+import           Stack.Types.Config import           System.FilePath                ((<.>)) import qualified System.FilePath                as FP import           System.IO                      (IOMode (ReadMode),@@ -291,9 +297,8 @@                     , T.pack $ packageIdentifierString ident                     , " with Git SHA of "                     , decodeUtf8 sha-                    , "\n"-                    , T.pack $ show e                     ]+                $logDebug (T.pack (show e))                 goPkg h Nothing (ident, pc, Nothing, tf)     goPkg h _mgit (ident, pc, _mgitsha, tf) = liftIO $ do         hSeek h AbsoluteSeek $ fromIntegral $ pcOffset pc@@ -485,7 +490,7 @@        -> (PackageIdentifier, ToFetch)        -> m ()     go outputVar runInBase (ident, toFetch) = do-        req <- parseUrl $ T.unpack $ tfUrl toFetch+        req <- parseUrlThrow $ T.unpack $ tfUrl toFetch         let destpath = tfTarball toFetch          let toHashCheck bs = HashCheck SHA512 (CheckHexDigestByteString bs)@@ -499,54 +504,30 @@                 liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download"         _ <- verifiedDownload downloadReq destpath progressSink -        let fp = toFilePath destpath+        identStrP <- parseRelDir $ packageIdentifierString ident          F.forM_ (tfDestDir toFetch) $ \destDir -> do-            let dest = toFilePath $ parent destDir-                innerDest = toFilePath destDir--            liftIO $ ensureDir (parent destDir)--            liftIO $ withBinaryFile fp ReadMode $ \h -> do-                -- Avoid using L.readFile, which is more likely to leak-                -- resources-                lbs <- L.hGetContents h-                let entries = fmap (either wrap wrap)-                            $ Tar.checkTarbomb identStr-                            $ Tar.read $ decompress lbs-                    wrap :: Exception e => e -> FetchException-                    wrap = Couldn'tReadPackageTarball fp . toException-                    identStr = packageIdentifierString ident--                    getPerms :: Tar.Entry -> (FilePath, Tar.Permissions)-                    getPerms e = (dest FP.</> Tar.fromTarPath (Tar.entryTarPath e),-                                  Tar.entryPermissions e)+            let innerDest = toFilePath destDir -                    filePerms :: [(FilePath, Tar.Permissions)]-                    filePerms = catMaybes $ Tar.foldEntries (\e -> (:) (Just $ getPerms e))-                                                            [] (const []) entries-                Tar.unpack dest entries-                -- Reset file permissions as they were in the tarball-                mapM_ (\(fp', perm) -> setFileMode-                    (FP.dropTrailingPathSeparator fp')-                    perm) filePerms+            unexpectedEntries <- liftIO $ untar destpath identStrP (parent destDir) +            liftIO $ do                 case mdistDir of                     Nothing -> return ()                     -- See: https://github.com/fpco/stack/issues/157                     Just distDir -> do-                        let inner = dest FP.</> identStr-                            oldDist = inner FP.</> "dist"-                            newDist = inner FP.</> toFilePath distDir-                        exists <- D.doesDirectoryExist oldDist+                        let inner = parent destDir </> identStrP+                            oldDist = inner </> $(mkRelDir "dist")+                            newDist = inner </> distDir+                        exists <- doesDirExist oldDist                         when exists $ do                             -- Previously used takeDirectory, but that got confused                             -- by trailing slashes, see:                             -- https://github.com/commercialhaskell/stack/issues/216                             --                             -- Instead, use Path which is a bit more resilient-                            ensureDir . parent =<< parseAbsDir newDist-                            D.renameDirectory oldDist newDist+                            ensureDir $ parent newDist+                            renameDir oldDist newDist                  let cabalFP =                         innerDest FP.</>@@ -555,6 +536,71 @@                 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++-- | Internal function used to unpack tarball.+--+-- Takes a path to a .tar.gz file, the name of the directory it should contain,+-- and a destination folder to extract the tarball into. Returns unexpected+-- entries, as pairs of paths and descriptions.+untar :: forall b1 b2. Path b1 File -> Path Rel Dir -> Path b2 Dir -> IO [(FilePath, T.Text)]+untar tarPath expectedTarFolder destDirParent = do+  ensureDir destDirParent+  withBinaryFile (toFilePath tarPath) ReadMode $ \h -> do+                -- Avoid using L.readFile, which is more likely to leak+                -- resources+                lbs <- L.hGetContents h+                let rawEntries = fmap (either wrap wrap)+                            $ Tar.checkTarbomb (toFilePathNoTrailingSep expectedTarFolder)+                            $ Tar.read $ decompress lbs++                    filterEntries+                      :: Monoid w => (Tar.Entry -> (Bool, w))+                         -> Tar.Entries b -> (Tar.Entries b, w)+                    -- Allow collecting warnings, Writer-monad style.+                    filterEntries f =+                      Tar.foldEntries+                        (\e -> let (res, w) = f e in+                            \(rest, wOld) -> ((if res then Tar.Next e else id) rest, wOld <> w))+                        (Tar.Done, mempty)+                        (\err -> (Tar.Fail err, mempty))++                    extractableEntry e =+                      case Tar.entryContent e of+                        Tar.NormalFile _ _ -> (True, [])+                        Tar.Directory -> (True, [])+                        Tar.SymbolicLink _ -> (True, [])+                        Tar.HardLink _ -> (True, [])+                        Tar.OtherEntryType 'g' _ _ -> (False, [])+                        Tar.OtherEntryType 'x' _ _ -> (False, [])+                        Tar.CharacterDevice _ _ -> (False, [(path, "character device")])+                        Tar.BlockDevice _ _ -> (False, [(path, "block device")])+                        Tar.NamedPipe -> (False, [(path, "named pipe")])+                        Tar.OtherEntryType code _ _ -> (False, [(path, "other entry type with code " <> T.pack (show code))])+                        where+                          path = Tar.fromTarPath $ Tar.entryTarPath e+                    (entries, unexpectedEntries) = filterEntries extractableEntry rawEntries++                    wrap :: Exception e => e -> FetchException+                    wrap = Couldn'tReadPackageTarball (toFilePath tarPath) . toException++                    getPerms :: Tar.Entry -> (FilePath, Tar.Permissions)+                    getPerms e = (toFilePath destDirParent FP.</> Tar.fromTarPath (Tar.entryTarPath e),+                                  Tar.entryPermissions e)++                    filePerms :: [(FilePath, Tar.Permissions)]+                    filePerms = catMaybes $ Tar.foldEntries (\e -> (:) (Just $ getPerms e))+                                                            [] (const []) entries+                Tar.unpack (toFilePath destDirParent) entries+                -- Reset file permissions as they were in the tarball, but only+                -- for extracted entries (whence filterEntries extractableEntry above).+                -- See https://github.com/commercialhaskell/stack/issues/2361+                mapM_ (\(fp, perm) -> setFileMode+                    (FP.dropTrailingPathSeparator fp)+                    perm) filePerms+                return unexpectedEntries  parMapM_ :: (F.Foldable f,MonadIO m,MonadBaseControl IO m)          => Int
src/Stack/GhcPkg.hs view
@@ -13,6 +13,7 @@   (getGlobalDB   ,EnvOverride   ,envHelper+  ,findGhcPkgField   ,createDatabase   ,unregisterGhcPkgId   ,getCabalPkgVer@@ -37,7 +38,12 @@ import           Path.IO import           Prelude hiding (FilePath) import           Stack.Constants-import           Stack.Types+import           Stack.Types.Build+import           Stack.Types.GhcPkgId+import           Stack.Types.PackageIdentifier+import           Stack.Types.Compiler+import           Stack.Types.PackageName+import           Stack.Types.Version import           System.FilePath (searchPathSeparator) import           System.Process.Read
src/Stack/Ghci.hs view
@@ -14,33 +14,38 @@     , GhciException(..)     , ghciSetup     , ghci++    -- TODO: Address what should and should not be exported.+    , renderScriptGhci+    , renderScriptIntero     ) where  import           Control.Applicative import           Control.Exception.Enclosed (tryAny)-import           Control.Monad+import           Control.Monad hiding (forM) import           Control.Monad.Catch import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.RWS.Strict-import           Control.Monad.State.Strict+import           Control.Monad.State.Strict (State, execState, get, modify)+import           Control.Monad.Reader (MonadReader, asks) import           Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.ByteString.Char8 as S8 import           Data.Either import           Data.Function import           Data.List import           Data.List.Extra (nubOrd)-import           Data.List.Split (splitOn) import           Data.Map.Strict (Map) import qualified Data.Map.Strict as M import           Data.Maybe import           Data.Maybe.Extra (forMaybeM)+import           Data.Monoid import           Data.Set (Set) import qualified Data.Set as S+import           Data.Traversable (forM) import           Data.Text (Text) import qualified Data.Text as T import           Data.Typeable (Typeable)-import           Distribution.ModuleName (ModuleName)+import           Distribution.PackageDescription (updatePackageDescription) import           Distribution.Text (display) import           Network.HTTP.Client.Conduit import           Path@@ -53,10 +58,15 @@ import           Stack.Build.Target import           Stack.Constants import           Stack.Exec+import           Stack.Ghci.Script import           Stack.Package-import           Stack.Types+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName+import           Stack.Types.Config+import           Stack.Types.Build+import           Stack.Types.Package+import           Stack.Types.Compiler import           Stack.Types.Internal-import           System.FilePath (takeBaseName) import           Text.Read (readMaybe)  #ifndef WINDOWS@@ -108,7 +118,7 @@ -- given options and configure it with the load paths and extensions -- of those targets. ghci-    :: (HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadBaseUnlift IO m)+    :: (HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadLoggerIO m, MonadBaseUnlift IO m)     => GhciOpts -> m () ghci opts@GhciOpts{..} = do     bopts <- asks (configBuild . getConfig)@@ -134,25 +144,8 @@         $logWarn             ("The following GHC options are incompatible with GHCi and have not been passed to it: " <>              T.unwords (map T.pack (nubOrd omittedOpts)))-    allModules <- checkForDuplicateModules ghciNoLoadModules pkgs+    mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs     oiDir <- objectInterfaceDir bconfig-    (modulesToLoad, mainFile) <- if ghciNoLoadModules then return ([], Nothing) else do-        mmainFile <- figureOutMainFile bopts mainIsTargets targets pkgs-        modulesToLoad <- case mmainFile of-            Just mainFile -> do-                let (_, mfDirs, mfName) = filePathPieces mainFile-                    mainPathPieces = map toFilePath mfDirs ++ [takeBaseName (toFilePath mfName)]-                liftM catMaybes $ forM allModules $ \mn -> do-                    let matchesModule = splitOn "." mn `isSuffixOf` mainPathPieces-                    if matchesModule-                        then do-                            $logWarn $ "Warning: Omitting load of module " <> T.pack mn <>-                               ", because it matches the filepath of the Main target, " <>-                               T.pack (toFilePath mainFile)-                            return Nothing-                        else return (Just mn)-            Nothing -> return allModules-        return (modulesToLoad, mmainFile)     let odir =             [ "-odir=" <> toFilePathNoTrailingSep oiDir             , "-hidir=" <> toFilePathNoTrailingSep oiDir ]@@ -168,21 +161,69 @@                  -- include CWD.                   "-i" :                   odir <> pkgopts <> ghciArgs <> extras)-    withSystemTempDir "ghci" $ \tmpDir -> do-        let macrosFile = tmpDir </> $(mkRelFile "cabal_macros.h")-        macrosOpts <- preprocessCabalMacros pkgs macrosFile-        if ghciNoLoadModules-            then execGhci macrosOpts-            else do-                let scriptPath = tmpDir </> $(mkRelFile "ghci-script")-                    fp = toFilePath scriptPath-                    loadModules = ":add " <> unwords (map show modulesToLoad)-                    addMainFile = maybe "" ((":add " <>) . toFilePath) mainFile-                    bringIntoScope = ":module + " <> unwords modulesToLoad-                liftIO (writeFile fp (unlines [loadModules,addMainFile,bringIntoScope]))-                setScriptPerms fp-                execGhci (macrosOpts ++ ["-ghci-script=" <> fp])+        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 +    withSystemTempDir "ghci" $ \tmpDirectory -> do+      macrosOptions <- writeMacrosFile tmpDirectory pkgs+      if ghciNoLoadModules+          then execGhci macrosOptions+          else do+              checkForDuplicateModules pkgs+              renderFn <- interrogateExeForRenderFunction+              scriptPath <- writeGhciScript tmpDirectory (renderFn pkgs mainFile)+              execGhci (macrosOptions ++ ["-ghci-script=" <> toFilePath scriptPath])++writeMacrosFile :: (MonadIO m) => Path Abs Dir -> [GhciPkgInfo] -> m [String]+writeMacrosFile tmpDirectory packages = do+  macrosOptions <- preprocessCabalMacros packages macrosFile+  return macrosOptions+  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+  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) -> GhciScript+renderScriptGhci pkgs mainFile =+  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 addPhase <> mainPhase <> modulePhase+  where+    renderPkg pkg = cmdAdd (ghciPkgModules pkg)++renderScriptIntero :: [GhciPkgInfo] -> Maybe (Path Abs File) -> GhciScript+renderScriptIntero pkgs mainFile =+  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 addPhase <> mainPhase <> modulePhase+  where+    renderPkg pkg = cmdCdGhc (ghciPkgDir pkg)+                 <> cmdAdd (ghciPkgModules pkg)+ -- | Figure out the main-is file to load based on the targets. Sometimes there -- is none, sometimes it's unambiguous, sometimes it's -- ambiguous. Warns and returns nothing if it's ambiguous.@@ -254,7 +295,7 @@         Just op -> do             let (_,_,fp) = candidates !! op             putStrLn-              ("Loading main module from cadidate " <>+              ("Loading main module from candidate " <>               show (op + 1) <> ", --main-is " <>               toFilePath fp)             putStrLn ""@@ -273,7 +314,7 @@ -- | Create a list of infos for each target containing necessary -- information to load that package/components. ghciSetup-    :: (HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadBaseUnlift IO m)+    :: (HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadLoggerIO m, MonadBaseUnlift IO m)     => GhciOpts     -> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo]) ghciSetup GhciOpts{..} = do@@ -291,16 +332,15 @@     let boptsCli = ghciBuildOptsCLI             { boptsCLITargets = boptsCLITargets ghciBuildOptsCLI ++ map T.pack ghciAdditionalPackages             }+    (realTargets,_,_,_,sourceMap) <- loadSourceMap AllowNoTargets boptsCli     -- Try to build, but optimistically launch GHCi anyway if it fails (#1065)-    unless ghciNoBuild $ do+    when (not ghciNoBuild && not (M.null realTargets)) $ do         eres <- tryAny $ build (const (return ())) Nothing boptsCli         case eres of             Right () -> return ()             Left err -> do                 $logError $ T.pack (show err)                 $logWarn "Warning: build failed, but optimistically launching GHCi anyway"-    econfig <- asks getEnvConfig-    (realTargets,_,_,_,sourceMap) <- loadSourceMap AllowNoTargets boptsCli     menv <- getMinimalEnvOverride     (installedMap, _, _, _) <- getInstalled         menv@@ -309,6 +349,7 @@             , getInstalledHaddock   = False             }         sourceMap+    econfig <- asks getEnvConfig     directlyWanted <-         forMaybeM (M.toList (envConfigPackages econfig)) $         \(dir,treatLikeExtraDep) ->@@ -379,7 +420,21 @@             , packageConfigCompilerVersion = envConfigCompilerVersion econfig             , packageConfigPlatform = configPlatform (getConfig bconfig)             }-    (warnings,pkg) <- readPackage config cabalfp+    (warnings,gpkgdesc) <- readPackageUnresolved cabalfp++    -- Source the package's *.buildinfo file created by configure if any. See+    -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters+    buildinfofp <- parseRelFile (T.unpack (packageNameText name) ++ ".buildinfo")+    hasDotBuildinfo <- doesFileExist (parent cabalfp </> buildinfofp)+    let mbuildinfofp+          | hasDotBuildinfo = Just (parent cabalfp </> buildinfofp)+          | otherwise = Nothing+    mbuildinfo <- forM mbuildinfofp readDotBuildinfo+    let pkg =+            packageFromPackageDescription config gpkgdesc $+            maybe id (updatePackageDescription) mbuildinfo $+            resolvePackageDescription config gpkgdesc+     mapM_ (printCabalFileWarning cabalfp) warnings     (mods,files,opts) <- getPackageOpts (packageOpts pkg) sourceMap installedMap locals addPkgs cabalfp     let filteredOpts = filterWanted opts@@ -413,7 +468,8 @@ checkForIssues :: (MonadThrow m, MonadLogger m) => [GhciPkgInfo] -> m () checkForIssues pkgs = do     unless (null issues) $ borderedWarning $ do-        $logWarn "There are issues with this project which may prevent GHCi from working properly."+        $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 ""@@ -481,15 +537,14 @@     $logWarn ""     return x -checkForDuplicateModules :: (MonadThrow m, MonadLogger m) => Bool -> [GhciPkgInfo] -> m [String]-checkForDuplicateModules noLoadModules pkgs = do+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:"             forM_ duplicates $ \(mn, pns) -> do                 $logWarn (" * " <> T.pack mn <> " (in " <> T.intercalate ", " (map packageNameText pns) <> ")")-        unless noLoadModules $ throwM LoadingDuplicateModules-    return (map fst allModules)+        throwM LoadingDuplicateModules   where     duplicates, allModules :: [(String, [PackageName])]     duplicates = filter (not . null . tail . snd) allModules@@ -545,7 +600,7 @@     let fps = nubOrd (concatMap (mapMaybe (bioCabalMacros . snd) . ghciPkgOpts) pkgs)     files <- mapM (S8.readFile . toFilePath) fps     if null files then return [] else do-        S8.writeFile (toFilePath out) $ S8.concat $ map (<> "\n#undef CURRENT_PACKAGE_KEY\n") files+        S8.writeFile (toFilePath out) $ S8.concat $ map (<> "\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") files         return ["-optP-include", "-optP" <> toFilePath out]  setScriptPerms :: MonadIO m => FilePath -> m ()@@ -562,9 +617,44 @@         ] #endif -filePathPieces :: Path Abs File -> (Path Abs Dir, [Path Rel Dir], Path Rel File)-filePathPieces x0 = go (parent x0, [], filename x0)-  where-    go (x, dirs, fp)-        | parent x == x = (x, dirs, fp)-        | otherwise = (parent x, dirname x : dirs, fp)+{- Copied from Stack.Ide, may be useful in the future++-- | Get options and target files for the given package info.+getPackageOptsAndTargetFiles+    :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env)+    => Path Abs Dir -> GhciPkgInfo -> m ([FilePath], [FilePath])+getPackageOptsAndTargetFiles pwd pkg = do+    dist <- distDirFromDir (ghciPkgDir pkg)+    let autogen = autogenDir dist+    paths_foo <-+        liftM+            (autogen </>)+            (parseRelFile+                 ("Paths_" ++ packageNameString (ghciPkgName pkg) ++ ".hs"))+    paths_foo_exists <- doesFileExist paths_foo+    let ghcOptions bio =+            bioOneWordOpts bio +++            bioOpts bio +++            bioPackageFlags bio +++            maybe [] (\cabalMacros -> ["-optP-include", "-optP" <> toFilePath cabalMacros]) (bioCabalMacros bio)+    return+        ( ("--dist-dir=" <> toFilePathNoTrailingSep dist) :+          map ("--ghc-option=" ++) (concatMap (ghcOptions . snd) (ghciPkgOpts pkg))+        , mapMaybe+              (fmap toFilePath . stripDir pwd)+              (S.toList (ghciPkgCFiles pkg) <> S.toList (ghciPkgModFiles pkg) <>+               [paths_foo | paths_foo_exists]))++-- | List load targets for a package target.+targetsCmd :: Text -> GlobalOpts -> IO ()+targetsCmd target go@GlobalOpts{..} =+    withBuildConfig go $+    do let boptsCli = defaultBuildOptsCLI { boptsCLITargets = [target] }+       (_realTargets,_,pkgs) <- ghciSetup (ideGhciOpts boptsCli)+       pwd <- getCurrentDir+       targets <-+           fmap+               (concat . snd . unzip)+               (mapM (getPackageOptsAndTargetFiles pwd) pkgs)+       forM_ targets (liftIO . putStrLn)+-}
+ src/Stack/Ghci/Script.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}++module Stack.Ghci.Script+  ( GhciScript+  , ModuleName++  , cmdAdd+  , cmdAddFile+  , cmdCdGhc+  , cmdModule++  , scriptToLazyByteString+  , scriptToBuilder+  , scriptToFile+  ) where++import           Control.Exception+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           System.IO++import           Distribution.ModuleName hiding (toFilePath)++newtype GhciScript = GhciScript { unGhciScript :: [GhciCommand] }++instance Monoid GhciScript where+  mempty = GhciScript []+  (GhciScript xs) `mappend` (GhciScript ys) = GhciScript (ys <> xs)++data GhciCommand+  = Add (Set ModuleName)+  | AddFile (Path Abs File)+  | CdGhc (Path Abs Dir)+  | Module (Set ModuleName)+  deriving (Show)++cmdAdd :: Set ModuleName -> GhciScript+cmdAdd = GhciScript . (:[]) . Add++cmdAddFile :: Path Abs File -> GhciScript+cmdAddFile = GhciScript . (:[]) . AddFile++cmdCdGhc :: Path Abs Dir -> GhciScript+cmdCdGhc = GhciScript . (:[]) . CdGhc++cmdModule :: Set ModuleName -> GhciScript+cmdModule = GhciScript . (:[]) . Module++scriptToLazyByteString :: GhciScript -> ByteString+scriptToLazyByteString = toLazyByteString . scriptToBuilder++scriptToBuilder :: GhciScript -> Builder+scriptToBuilder backwardScript = mconcat $ fmap commandToBuilder script+  where+    script = reverse $ unGhciScript backwardScript++scriptToFile :: Path Abs File -> GhciScript -> IO ()+scriptToFile path script =+  bracket (openFile filepath WriteMode) hClose+    $ \hdl -> do hSetBuffering hdl (BlockBuffering Nothing)+                 hSetBinaryMode hdl True+                 hPutBuilder hdl (scriptToBuilder script)+  where+    filepath = toFilePath path++-- Command conversion++fromText :: Text -> Builder+fromText = encodeUtf8Builder++commandToBuilder :: GhciCommand -> Builder++commandToBuilder (Add modules)+  | S.null modules = mempty+  | otherwise      =+       fromText ":add "+    <> (mconcat $ intersperse (fromText " ")+        $ fmap (stringUtf8 . quoteFileName . mconcat . intersperse "." . components)+        $ 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"++commandToBuilder (Module modules)+  | S.null modules = fromText ":module +\n"+  | otherwise      =+       fromText ":module + "+    <> (mconcat $ intersperse (fromText " ")+        $ fmap (stringUtf8 . quoteFileName . mconcat . intersperse "." . components)+        $ S.toAscList modules)+    <> fromText "\n"++-- | Make sure that a filename with spaces in it gets the proper quotes.+quoteFileName :: String -> String+quoteFileName x =+    if any (==' ') x+        then show x+        else x
+ src/Stack/Hoogle.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- | A wrapper around hoogle.+module Stack.Hoogle+    ( hoogleCmd+    ) where++import           Control.Exception+import           Control.Monad.IO.Class+import           Control.Monad.Logger+import           Control.Monad.Reader+import qualified Data.ByteString.Char8 as S8+import           Data.List (find)+import qualified Data.Map.Strict as Map+import           Data.Monoid+import qualified Data.Set as Set+import           Lens.Micro+import           Path+import           Path.IO+import qualified Stack.Build+import           Stack.Fetch+import           Stack.Runners+import           Stack.Types.Config+import           Stack.Types.Internal+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.Run++-- | Hoogle command.+hoogleCmd :: ([String],Bool,Bool) -> GlobalOpts -> IO ()+hoogleCmd (args,setup,rebuild) go = withBuildConfig go pathToHaddocks+  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+        databaseExists <- checkDatabaseExists+        if databaseExists && not rebuild+            then runHoogle args+            else if setup || rebuild+                     then do+                         $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+                     else do+                         $logError+                             "No Hoogle database. Not building one due to --no-setup"+                         bail+    generateDb :: StackT EnvConfig IO ()+    generateDb = do+        do dir <- hoogleRoot+           createDirIfMissing True dir+           runHoogle ["generate", "--local"]+    buildHaddocks :: StackT EnvConfig IO ()+    buildHaddocks =+        liftIO+            (catch+                 (withBuildConfigAndLock+                      (set+                           (globalOptsBuildOptsMonoid . buildOptsMonoidHaddock)+                           (Just True)+                           go)+                      (\lk ->+                            Stack.Build.build+                                (const (return ()))+                                lk+                                defaultBuildOptsCLI))+                 (\(_ :: ExitCode) ->+                       return ()))+    installHoogle :: StackT EnvConfig IO ()+    installHoogle = do+        let hooglePackageName = $(mkPackageName "hoogle")+            hoogleMinVersion = $(mkVersion "5.0")+            hoogleMinIdent =+                PackageIdentifier hooglePackageName hoogleMinVersion+        hooglePackageIdentifier <-+            do (_,_,resolved) <-+                   resolvePackagesAllowMissing+                       mempty+                       (Set.fromList [hooglePackageName])+               return+                   (case find+                             ((== hooglePackageName) . packageIdentifierName)+                             (Map.keys resolved) of+                        Just ident@(PackageIdentifier _ ver)+                          | ver >= hoogleMinVersion -> Right ident+                        _ -> Left hoogleMinIdent)+        case hooglePackageIdentifier of+            Left{} ->+                $logInfo+                    ("Minimum " <> packageIdentifierText hoogleMinIdent <>+                     " is not in your index. Installing the minimum version.")+            Right ident ->+                $logInfo+                    ("Minimum version is " <> packageIdentifierText hoogleMinIdent <>+                     ". Found acceptable " <>+                     packageIdentifierText ident <>+                     " in your index, installing it.")+        config <- asks getConfig+        menv <- liftIO $ configEnvOverride config envSettings+        liftIO+            (catch+                 (withBuildConfigAndLock+                      go+                      (\lk ->+                            Stack.Build.build+                                (const (return ()))+                                lk+                                defaultBuildOptsCLI+                                { boptsCLITargets = [ packageIdentifierText+                                                          (either+                                                               id+                                                               id+                                                               hooglePackageIdentifier)]+                                }))+                 (\(e :: ExitCode) ->+                       case e of+                           ExitSuccess -> resetExeCache menv+                           _ -> throwIO e))+    runHoogle :: [String] -> StackT EnvConfig IO ()+    runHoogle hoogleArgs = do+        config <- asks getConfig+        menv <- liftIO $ configEnvOverride config envSettings+        dbpath <- hoogleDatabasePath+        let databaseArg = ["--database=" ++ toFilePath dbpath]+        runCmd+            (Cmd+             { cmdDirectoryToRunIn = Nothing+             , cmdCommandToRun = "hoogle"+             , cmdEnvOverride = menv+             , cmdCommandLineArguments = hoogleArgs ++ databaseArg+             })+            Nothing+    bail :: StackT EnvConfig IO ()+    bail = liftIO (exitWith (ExitFailure (-1)))+    checkDatabaseExists = do+        path <- hoogleDatabasePath+        liftIO (doesFileExist path)+    checkHoogleInPath = do+        config <- asks getConfig+        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+    envSettings =+        EnvSettings+        { esIncludeLocals = True+        , esIncludeGhcPackagePath = True+        , esStackExe = True+        , esLocaleUtf8 = False+        }
+ src/Stack/IDE.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- | Functions for IDEs.+module Stack.IDE+    ( listPackages+    , listTargets+    ) where++import           Control.Monad.Catch+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.Package (findOrGenerateCabalFile)+import           Stack.Types.Config+import           Stack.Types.Package+import           Stack.Types.PackageName++-- | List the packages inside the current project.+listPackages+    :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, MonadLogger m)+    => m ()+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 <- asks (Map.keys . envConfigPackages . getEnvConfig)+    forM_ packageDirs $ \dir -> do+        cabalfp <- findOrGenerateCabalFile dir+        pkgName <- parsePackageNameFromFilePath cabalfp+        ($logInfo . packageNameText) pkgName++-- | List the targets in the current project.+listTargets+    :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, MonadLogger m)+    => m ()+listTargets =+    do rawLocals <- getLocalPackageViews+       $logInfo+           (T.intercalate+                "\n"+                (map+                     renderPkgComponent+                     (concatMap+                          toNameAndComponent+                          (Map.toList (Map.map fst rawLocals)))))+  where+    toNameAndComponent (pkgName,view) =+        map (pkgName, ) (Set.toList (lpvComponents view))
− src/Stack/Ide.hs 
@@ -1,125 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}---- | Run a IDE configured with the user's package(s).--module Stack.Ide-    (ide, getPackageOptsAndTargetFiles, ideGhciOpts)-    where--import           Control.Monad.Catch-import           Control.Monad.IO.Class-import           Control.Monad.Logger-import           Control.Monad.Reader-import           Control.Monad.Trans.Unlift (MonadBaseUnlift)-import           Data.List-import           Data.Maybe-import           Data.Monoid-import qualified Data.Set as S-import           Data.Text (Text)-import           Distribution.System-import           Network.HTTP.Client.Conduit-import           Path-import           Path.Extra (toFilePathNoTrailingSep)-import           Path.IO-import           Stack.Constants-import           Stack.Ghci (GhciPkgInfo(..), GhciOpts(..), ghciSetup)-import           Stack.Package-import           Stack.Types-import           Stack.Types.Internal-import           System.Environment (lookupEnv)-import           System.FilePath (searchPathSeparator)-import           System.Process.Run---- | Launch a GHCi IDE for the given local project targets with the--- given options and configure it with the load paths and extensions--- of those targets.-ide-    :: (HasConfig r, HasBuildConfig r, HasTerminal r, HasLogLevel r, MonadMask m, HasEnvConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadBaseUnlift IO m, HasHttpManager r)-    => [Text] -- ^ Targets.-    -> [String] -- ^ GHC options.-    -> m ()-ide targets useropts = do-    let boptsCli = defaultBuildOptsCLI-            { boptsCLITargets = targets-            , boptsCLIBuildSubset = BSOnlyDependencies-            }-    (_realTargets,_,pkgs) <- ghciSetup (ideGhciOpts boptsCli)-    pwd <- getCurrentDir-    (pkgopts,_srcfiles) <--        liftM mconcat $ forM pkgs $ getPackageOptsAndTargetFiles pwd-    localdb <- packageDatabaseLocal-    depsdb <- packageDatabaseDeps-    mpath <- liftIO $ lookupEnv "PATH"-    bindirs <- extraBinDirs `ap` return True {- include local bin -}-    let pkgdbs =-            ["--package-db=" <> toFilePathNoTrailingSep depsdb <> [searchPathSeparator] <> toFilePathNoTrailingSep localdb]-        paths =-            [ "--ide-backend-tools-path=" <>-              intercalate [searchPathSeparator] (map toFilePath bindirs) <>-              maybe "" (searchPathSeparator :) mpath]-        args =-            ["--verbose"] <> ["--include=" <> includeDirs pkgopts] <>-            ["--local-work-dir=" ++ toFilePathNoTrailingSep pwd] <>-            map ("--ghc-option=" ++) useropts <>-            paths <>-            pkgopts <>-            pkgdbs-    menv <- getMinimalEnvOverride-    Platform _ os <- asks getPlatform-    when-        (os == OSX)-        (catch (callProcess (Cmd (Just pwd) "stty" menv ["cbreak", "-imaxbel"]))-               (\(_ :: ProcessExitedUnsuccessfully) -> return ()))-    callProcess (Cmd (Just pwd) "stack-ide" menv args)-  where-    includeDirs pkgopts =-        intercalate-            [searchPathSeparator]-            (mapMaybe-                 (stripPrefix "--ghc-option=-i")-                 pkgopts)---- | Get options and target files for the given package info.-getPackageOptsAndTargetFiles-    :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env)-    => Path Abs Dir -> GhciPkgInfo -> m ([FilePath], [FilePath])-getPackageOptsAndTargetFiles pwd pkg = do-    dist <- distDirFromDir (ghciPkgDir pkg)-    let autogen = autogenDir dist-    paths_foo <--        liftM-            (autogen </>)-            (parseRelFile-                 ("Paths_" ++ packageNameString (ghciPkgName pkg) ++ ".hs"))-    paths_foo_exists <- doesFileExist paths_foo-    let ghcOptions bio =-            bioOneWordOpts bio ++-            bioOpts bio ++-            bioPackageFlags bio ++-            maybe [] (\cabalMacros -> ["-optP-include", "-optP" <> toFilePath cabalMacros]) (bioCabalMacros bio)-    return-        ( ("--dist-dir=" <> toFilePathNoTrailingSep dist) :-          map ("--ghc-option=" ++) (concatMap (ghcOptions . snd) (ghciPkgOpts pkg))-        , mapMaybe-              (fmap toFilePath . stripDir pwd)-              (S.toList (ghciPkgCFiles pkg) <> S.toList (ghciPkgModFiles pkg) <>-               [paths_foo | paths_foo_exists]))--ideGhciOpts :: BuildOptsCLI -> GhciOpts-ideGhciOpts boptsCli = GhciOpts-    { ghciNoBuild = False-    , ghciArgs = []-    , ghciGhcCommand = Nothing-    , ghciNoLoadModules = False-    , ghciAdditionalPackages = []-    , ghciMainIs = Nothing-    , ghciLoadLocalDeps = False-    , ghciSkipIntermediate = False-    , ghciHidePackages = True-    , ghciBuildOptsCLI = boptsCli-    }
src/Stack/Image.hs view
@@ -28,7 +28,8 @@ import           Path.Extra import           Path.IO import           Stack.Constants-import           Stack.Types+import           Stack.Types.Config+import           Stack.Types.Image import           Stack.Types.Internal import           System.Process.Run @@ -40,11 +41,15 @@ -- directory under '.stack-work' stageContainerImageArtifacts     :: Build e m-    => Maybe (Path Abs Dir) -> m ()-stageContainerImageArtifacts mProjectRoot = do+    => Maybe (Path Abs Dir) -> [Text] -> m ()+stageContainerImageArtifacts mProjectRoot imageNames = do     config <- asks getConfig     forM_-        (zip [0 ..] (imgDockers $ configImage config))+        (zip+             [0 ..]+             (filterImages+                  (map T.unpack imageNames)+                  (imgDockers $ configImage config)))         (\(idx,opts) ->               do imageDir <-                      imageStagingDir (fromMaybeProjectRoot mProjectRoot) idx@@ -73,11 +78,13 @@                      imageStagingDir (fromMaybeProjectRoot mProjectRoot) idx                  createDockerImage opts imageDir                  extendDockerImageWithEntrypoint opts imageDir)++filterImages :: [String] -> [ImageDockerOpts] -> [ImageDockerOpts]+filterImages [] = id -- all: no filter+filterImages names = filter (imageNameFound . imgDockerImageName)   where-    filterImages [] = id -- all: no filter-    filterImages names = filter (imageNameFound names . imgDockerImageName)-    imageNameFound names (Just name) = name `elem` names-    imageNameFound _ _ = False+    imageNameFound (Just name) = name `elem` names+    imageNameFound _ = False  -- | Stage all the Package executables in the usr/local/bin -- subdirectory of a temp directory.@@ -94,10 +101,9 @@             forM_                 exes                 (\exe ->-                      do exeRelFile <- parseRelFile exe-                         copyFile-                             (srcBinPath </> exeRelFile)-                             (destBinPath </> exeRelFile))+                      copyFile+                          (srcBinPath </> exe)+                          (destBinPath </> exe))  -- | Add any additional files into the temp directory, respecting the -- (Source, Destination) mapping.@@ -109,9 +115,8 @@     let imgAdd = imgDockerAdd opts     forM_         (Map.toList imgAdd)-        (\(source,dest) ->+        (\(source,destPath) ->               do sourcePath <- resolveDir (bcRoot bconfig) source-                 destPath <- parseAbsDir dest                  let destFullPath = dir </> dropRoot destPath                  ensureDir destFullPath                  copyDirRecur sourcePath destFullPath)
src/Stack/Init.hs view
@@ -44,7 +44,12 @@                                                   makeConcreteResolver) import           Stack.Constants import           Stack.Solver-import           Stack.Types+import           Stack.Types.BuildPlan+import           Stack.Types.FlagName+import           Stack.Types.PackageName+import           Stack.Types.Version+import           Stack.Types.Config+import           Stack.Types.Build import           Stack.Types.Internal            (HasLogLevel, HasReExec,                                                   HasTerminal) import qualified System.FilePath                 as FP@@ -199,7 +204,9 @@                 if (name == "packages") then commentedPackages else "" <>                 B.byteString "\n" -    commentHelp = BC.pack .  intercalate "\n" . map ("# " ++)+    commentLine l | null l = "#"+                  | otherwise = "# " ++ l+    commentHelp = BC.pack .  intercalate "\n" . map commentLine     commentedPackages =         let ignoredComment = commentHelp                 [ "The following packages have been ignored due to incompatibility with the"
src/Stack/New.hs view
@@ -54,7 +54,8 @@ import           Path.IO import           Prelude import           Stack.Constants-import           Stack.Types+import           Stack.Types.PackageName+import           Stack.Types.Config import           Stack.Types.TemplateName import           System.Process.Run import           Text.Hastache@@ -129,16 +130,14 @@ -- | Download and read in a template's text content. loadTemplate     :: forall m r.-       (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m)+       (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadCatch m, MonadLogger m)     => TemplateName -> (TemplateFrom -> m ()) -> m Text loadTemplate name logIt = do     templateDir <- asks (templatesDir . getConfig)     case templatePath name of         AbsPath absFile -> logIt LocalTemp >> loadLocalFile absFile         UrlPath s -> do-            let req = fromMaybe (error "impossible happened: already valid \-                                       \URL couldn't be parsed")-                                (parseUrl s)+            let req = parseRequest_ s                 rel = fromMaybe backupUrlRelPath (parseRelFile s)             downloadTemplate req (templateDir </> rel)         RelPath relFile ->@@ -162,7 +161,7 @@             then liftIO (T.readFile (toFilePath path))             else throwM (FailedToLoadTemplate name (toFilePath path))     relRequest :: MonadThrow n => Path Rel File -> n Request-    relRequest rel = parseUrl (defaultTemplateUrl <> "/" <> toFilePath rel)+    relRequest rel = parseRequest (defaultTemplateUrl <> "/" <> toFilePath rel)     downloadTemplate :: Request -> Path Abs File -> m Text     downloadTemplate req path = do         logIt RemoteTemp@@ -293,7 +292,7 @@     :: (MonadIO m, MonadReader r m, HasHttpManager r, MonadCatch m)     => m (Set TemplateName) getTemplates = do-    req <- liftM addHeaders (parseUrl defaultTemplatesList)+    req <- liftM addHeaders (parseUrlThrow defaultTemplatesList)     resp <- catch (httpLbs req) (throwM . FailedToDownloadTemplates)     case statusCode (responseStatus resp) of         200 ->@@ -307,7 +306,7 @@     :: (MonadIO m, MonadReader r m, HasHttpManager r, MonadCatch m)     => m (Map Text TemplateInfo) getTemplateInfo = do-  req <- liftM addHeaders (parseUrl defaultTemplateInfoUrl)+  req <- liftM addHeaders (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
src/Stack/Nix.hs view
@@ -33,12 +33,13 @@ import           Path.IO import qualified Paths_stack as Meta import           Prelude hiding (mapM) -- Fix redundant import warnings-import           Stack.Config (makeConcreteResolver) import           Stack.Config.Nix (nixCompiler) import           Stack.Constants (stackProgName,platformVariantEnvVar)-import           Stack.Docker (reExecArgName) import           Stack.Exec (exec)-import           Stack.Types+import           Stack.Types.Config+import           Stack.Types.Docker+import           Stack.Types.Nix+import           Stack.Types.Compiler import           Stack.Types.Internal import           System.Environment (lookupEnv,getArgs,getExecutablePath) import           System.Process.Read (getEnvOverride)@@ -48,16 +49,15 @@ reexecWithOptionalShell     :: M env m     => Maybe (Path Abs Dir)-    -> Maybe AbstractResolver-    -> Maybe CompilerVersion+    -> IO CompilerVersion     -> IO ()     -> m ()-reexecWithOptionalShell mprojectRoot maresolver mcompiler inner =+reexecWithOptionalShell mprojectRoot getCompilerVersion inner =   do config <- asks getConfig      inShell <- getInShell      isReExec <- asks getReExec      if nixEnable (configNix config) && not inShell && not isReExec-       then runShellAndExit mprojectRoot maresolver mcompiler getCmdArgs+       then runShellAndExit mprojectRoot getCompilerVersion getCmdArgs        else liftIO inner   where     getCmdArgs = do@@ -71,35 +71,43 @@ runShellAndExit     :: M env m     => Maybe (Path Abs Dir)-    -> Maybe AbstractResolver-    -> Maybe CompilerVersion+    -> IO CompilerVersion     -> m (String, [String])     -> m ()-runShellAndExit mprojectRoot maresolver mcompiler getCmdArgs = do+runShellAndExit mprojectRoot getCompilerVersion getCmdArgs = do      config <- asks getConfig-     mresolver <- mapM makeConcreteResolver maresolver      envOverride <- getEnvOverride (configPlatform config)      (cmnd,args) <- fmap (escape *** map escape) getCmdArgs      mshellFile <-          traverse (resolveFile (fromMaybeProjectRoot mprojectRoot)) $          nixInitFile (configNix config)+     compilerVersion <- liftIO getCompilerVersion      let pkgsInConfig = nixPackages (configNix config)-         pkgs = pkgsInConfig ++ [nixCompiler config mresolver mcompiler]+         ghc = nixCompiler compilerVersion+         pkgs = pkgsInConfig ++ [ghc]+         pkgsStr = "[" <> T.intercalate " " pkgs <> "]"          pureShell = nixPureShell (configNix config)          nixopts = case mshellFile of-           Just fp -> [toFilePath fp]-           Nothing -> ["-E", T.unpack $ T.intercalate " " $ concat-                              [["with (import <nixpkgs> {});"-                               ,"runCommand \"myEnv\" {"-                               ,"buildInputs=lib.optional stdenv.isLinux glibcLocales ++ ["],pkgs,["];"-                               ,T.pack platformVariantEnvVar <> "=''nix'';"-                               ,T.pack inShellEnvVar <> "=1;"-                               ,"STACK_IN_NIX_EXTRA_ARGS=''"]-                               ,      (map (\p -> T.concat-                                                  ["--extra-lib-dirs=${",p,"}/lib"-                                                  ," --extra-include-dirs=${",p,"}/include "])-                                           pkgs), ["'' ;"-                               ,"} \"\""]]]+           Just fp -> [toFilePath fp, "--arg", "ghc"+                      ,"with (import <nixpkgs> {}); " ++ T.unpack ghc]+           Nothing -> ["-E", T.unpack $ T.concat+                              ["with (import <nixpkgs> {}); "+                              ,"let inputs = ",pkgsStr,"; "+                              ,    "libPath = lib.makeLibraryPath inputs; "+                              ,    "stackExtraArgs = lib.concatStrings ("+                              ,      "lib.foldl' (acc: p: acc ++ [\" --extra-lib-dirs \" p]) [] "+                              ,        "(lib.splitString '':'' libPath) ++ "+                              ,      "lib.foldl' (acc: p: acc ++ [\" --extra-include-dirs \" p]) [] "+                              ,        "(lib.splitString '':'' (lib.makeSearchPathOutput ''dev'' ''include'' inputs))"+                              ,    "); in "+                              ,"runCommand ''myEnv'' { "+                              ,"buildInputs = lib.optional stdenv.isLinux glibcLocales ++ inputs; "+                              ,T.pack platformVariantEnvVar <> "=''nix''; "+                              ,T.pack inShellEnvVar <> "=1; "+                              ,"LD_LIBRARY_PATH = libPath;"  -- LD_LIBRARY_PATH is set because for now it's+                               -- needed by builds using Template Haskell+                              ,"STACK_IN_NIX_EXTRA_ARGS = stackExtraArgs; "+                              ,"} \"\""]]                     -- glibcLocales is necessary on Linux to avoid warnings about GHC being incapable to set the locale.          fullArgs = concat [if pureShell then ["--pure"] else [],                             map T.unpack (nixShellOptions (configNix config))@@ -123,7 +131,7 @@  -- | Fail with friendly error if project root not set. fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir-fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException)+fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRoot)  -- | 'True' if we are currently running inside a Nix. getInShell :: (MonadIO m) => m Bool@@ -144,14 +152,14 @@  -- | Exceptions thrown by "Stack.Nix". data StackNixException-  = CannotDetermineProjectRootException+  = CannotDetermineProjectRoot     -- ^ Can't determine the project root (location of the shell file if any).   deriving (Typeable)  instance Exception StackNixException  instance Show StackNixException where-  show CannotDetermineProjectRootException =+  show CannotDetermineProjectRoot =     "Cannot determine project root directory."  type M env m =
src/Stack/Options.hs view
@@ -41,12 +41,13 @@ import qualified Data.Set                          as Set import qualified Data.Text                         as T import           Data.Text.Read                    (decimal)+import           Data.Version                      (showVersion) import           Distribution.Version              (anyVersion) import           Options.Applicative import           Options.Applicative.Args import           Options.Applicative.Builder.Extra import           Options.Applicative.Types         (fromM, oneM, readerAsk)-import           Path+import           Paths_stack                       as Meta import           Stack.Build                       (splitObjsWarning) import           Stack.Clean                       (CleanOpts (..)) import           Stack.Config                      (packagesParser)@@ -60,7 +61,13 @@ import           Stack.Init import           Stack.New import           Stack.Nix-import           Stack.Types+import           Stack.Types.FlagName+import           Stack.Types.PackageName+import           Stack.Types.Version+import           Stack.Types.Config+import           Stack.Types.Docker+import           Stack.Types.Nix+import           Stack.Types.Compiler import           Stack.Types.TemplateName  -- | Allows adjust global options depending on their context@@ -96,7 +103,10 @@     many         (textArgument              (metavar "TARGET" <>-              help "If none specified, use all packages")) <*>+              help ("If none specified, use all packages. " <>+                    "See https://docs.haskellstack.org/en/v" <>+                    showVersion Meta.version <>+                    "/build_command/#target-syntax for details."))) <*>     switch         (long "dry-run" <>          help "Don't build anything, just prepare to") <*>@@ -203,7 +213,7 @@ -- | Command-line arguments parser for configuration. configOptsParser :: GlobalOptsContext -> Parser ConfigMonoid configOptsParser hide0 =-    (\stackRoot workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage allowDifferentUser -> mempty+    (\stackRoot workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch ghcVariant jobs includes libs overrideGccPath skipGHCCheck skipMsys localBin modifyCodePage allowDifferentUser -> mempty         { configMonoidStackRoot = stackRoot         , configMonoidWorkDir = workDir         , configMonoidBuildOpts = buildOpts@@ -213,24 +223,24 @@         , configMonoidInstallGHC = installGHC         , configMonoidSkipGHCCheck = skipGHCCheck         , configMonoidArch = arch-        , configMonoidOS = os         , configMonoidGHCVariant = ghcVariant         , configMonoidJobs = jobs         , configMonoidExtraIncludeDirs = includes         , configMonoidExtraLibDirs = libs+        , configMonoidOverrideGccPath = overrideGccPath         , configMonoidSkipMsys = skipMsys         , configMonoidLocalBinPath = localBin         , configMonoidModifyCodePage = modifyCodePage         , configMonoidAllowDifferentUser = allowDifferentUser         })-    <$> optionalFirst (option readAbsDir+    <$> optionalFirst (absDirOption             ( long stackRootOptionName             <> metavar (map toUpper stackRootOptionName)             <> help ("Absolute path to the global stack root directory " ++                      "(Overrides any STACK_ROOT environment variable)")             <> hide             ))-    <*> optionalFirst (strOption+    <*> optionalFirst (relDirOption             ( long "work-dir"             <> metavar "WORK-DIR"             <> help "Override work directory (default: .stack-work)"@@ -253,12 +263,6 @@            <> help "System architecture, e.g. i386, x86_64"            <> hide             ))-    <*> optionalFirst (strOption-            ( long "os"-           <> metavar "OS"-           <> help "Operating system, e.g. linux, windows"-           <> hide-            ))     <*> optionalFirst (ghcVariantParser (hide0 /= OuterGlobalOpts))     <*> optionalFirst (option auto             ( long "jobs"@@ -267,18 +271,24 @@            <> help "Number of concurrent jobs to run"            <> hide             ))-    <*> fmap Set.fromList (many (textOption+    <*> fmap Set.fromList (many (absDirOption             ( long "extra-include-dirs"            <> metavar "DIR"            <> help "Extra directories to check for C header files"            <> hide             )))-    <*> fmap Set.fromList (many (textOption+    <*> fmap Set.fromList (many (absDirOption             ( long "extra-lib-dirs"            <> metavar "DIR"            <> help "Extra directories to check for libraries"            <> hide             )))+    <*> optionalFirst (absFileOption+             ( long "with-gcc"+            <> metavar "PATH-TO-GCC"+            <> help "Use gcc found at PATH-TO-GCC"+            <> hide+             ))     <*> firstBoolFlags             "skip-ghc-check"             "skipping the GHC version and architecture check"@@ -304,15 +314,6 @@             hide   where hide = hideMods (hide0 /= OuterGlobalOpts) -readAbsDir :: ReadM (Path Abs Dir)-readAbsDir = do-    s <- readerAsk-    case parseAbsDir s of-        Just p -> return p-        Nothing ->-            readerError-                ("Failed to parse absolute path to directory: '" ++ s ++ "'")- buildOptsMonoidParser :: Bool -> Parser BuildOptsMonoid buildOptsMonoidParser hide0 =     transform <$> trace <*> profile <*> options@@ -361,7 +362,7 @@              help                  "Enable profiling in libraries, executables, etc. \                     \for all expressions and generate a profiling report\-                    \ in exec or benchmarks" <>+                    \ in tests or benchmarks" <>             hide)      trace =@@ -548,11 +549,12 @@                                 metavar "NAME=VALUE" <>                                 help ("Set environment variable in container " ++                                       "(may specify multiple times)")))-    <*> firstStrOption (long (dockerOptName dockerDatabasePathArgName) <>-                        hide <>-                        metavar "PATH" <>-                        help "Location of image usage tracking database")-    <*> firstStrOption+    <*> optionalFirst (absFileOption+            (long (dockerOptName dockerDatabasePathArgName) <>+             hide <>+             metavar "PATH" <>+             help "Location of image usage tracking database"))+    <*> optionalFirst (option (eitherReader' parseDockerStackExe)             (long(dockerOptName dockerStackExeArgName) <>              hide <>              metavar (intercalate "|"@@ -562,7 +564,7 @@                           , "PATH" ]) <>              help (concat [ "Location of "                           , stackProgName-                          , " executable used in container" ]))+                          , " executable used in container" ])))     <*> firstBoolFlags (dockerOptName dockerSetUserArgName)                        "setting user in container to match host"                        hide
src/Stack/Package.hs view
@@ -18,9 +18,11 @@   (readPackage   ,readPackageBS   ,readPackageDescriptionDir+  ,readDotBuildinfo   ,readPackageUnresolved   ,readPackageUnresolvedBS   ,resolvePackage+  ,packageFromPackageDescription   ,findOrGenerateCabalFile   ,hpack   ,Package(..)@@ -87,7 +89,15 @@ import           Safe (headDef, tailSafe) import           Stack.Build.Installed import           Stack.Constants-import           Stack.Types+import           Stack.Types.FlagName+import           Stack.Types.GhcPkgId+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.Compiler import qualified System.Directory as D import           System.FilePath (splitExtensions, replaceExtension) import qualified System.FilePath as FilePath@@ -146,6 +156,17 @@     gdesc   <- liftM snd (readPackageUnresolved cabalfp)     return (gdesc, resolvePackageDescription config gdesc) +-- | Read @<package>.buildinfo@ ancillary files produced by some Setup.hs hooks.+-- The file includes Cabal file syntax to be merged into the package description+-- derived from the package's .cabal file.+--+-- NOTE: not to be confused with BuildInfo, an Stack-internal datatype.+readDotBuildinfo :: MonadIO m+                 => Path Abs File+                 -> m HookedBuildInfo+readDotBuildinfo buildinfofp =+    liftIO $ readHookedBuildInfo D.silent (toFilePath buildinfofp)+ -- | Print cabal file warnings. printCabalFileWarning     :: (MonadLogger m)@@ -179,6 +200,16 @@                -> GenericPackageDescription                -> Package resolvePackage packageConfig gpkg =+    packageFromPackageDescription+        packageConfig+        gpkg+        (resolvePackageDescription packageConfig gpkg)++packageFromPackageDescription :: PackageConfig+                              -> GenericPackageDescription+                              -> PackageDescription+                              -> Package+packageFromPackageDescription packageConfig gpkg pkg =     Package     { packageName = name     , packageVersion = fromCabalVersion (pkgVersion pkgId)@@ -210,7 +241,7 @@           False           (not . null . exposedModules)           (library pkg)-    , packageSimpleType = buildType (packageDescription gpkg) == Just Simple+    , packageSimpleType = buildType pkg == Just Simple     }   where     pkgFiles = GetPackageFiles $@@ -236,9 +267,8 @@                     hpackExists <- doesFileExist hpackPath                     return $ if hpackExists then S.singleton hpackPath else S.empty                 return (componentModules, componentFiles, buildFiles <> dataFiles', warnings)-    pkgId = package (packageDescription gpkg)+    pkgId = package pkg     name = fromCabalPackageName (pkgName pkgId)-    pkg = resolvePackageDescription packageConfig gpkg     deps = M.filterWithKey (const . (/= name)) (packageDependencies pkg)  -- | Generate GHC options for the package's components, and a list of@@ -318,8 +348,8 @@     , biAddPackages :: ![PackageName]     , biBuildInfo :: !BuildInfo     , biDotCabalPaths :: !(Set DotCabalPath)-    , biConfigLibDirs :: !(Set Text)-    , biConfigIncludeDirs :: !(Set Text)+    , biConfigLibDirs :: !(Set (Path Abs Dir))+    , biConfigIncludeDirs :: !(Set (Path Abs Dir))     , biComponentName :: !NamedComponent     } @@ -350,7 +380,7 @@     deps =         concat             [ case M.lookup name biInstalledMap of-                Just (_, Stack.Types.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)@@ -381,7 +411,7 @@     includeOpts =         map ("-I" <>) (configExtraIncludeDirs <> pkgIncludeOpts)     configExtraIncludeDirs =-        map T.unpack (S.toList biConfigIncludeDirs)+        map toFilePathNoTrailingSep (S.toList biConfigIncludeDirs)     pkgIncludeOpts =         [ toFilePathNoTrailingSep absDir         | dir <- includeDirs biBuildInfo@@ -391,7 +421,7 @@         map ("-l" <>) (extraLibs biBuildInfo) <>         map ("-L" <>) (configExtraLibDirs <> pkgLibDirs)     configExtraLibDirs =-        map T.unpack (S.toList biConfigLibDirs)+        map toFilePathNoTrailingSep (S.toList biConfigLibDirs)     pkgLibDirs =         [ toFilePathNoTrailingSep absDir         | dir <- extraLibDirs biBuildInfo@@ -536,7 +566,9 @@             (mapM                  (asModuleAndFileMap benchComponent benchmarkFiles)                  (benchmarks pkg))-    (dfiles) <- resolveGlobFiles (map (dataDir pkg FilePath.</>) (dataFiles pkg))+    (dfiles) <- resolveGlobFiles+                    (extraSrcFiles pkg+                        ++ map (dataDir pkg FilePath.</>) (dataFiles pkg))     let modules = libraryMods <> executableMods <> testMods <> benchModules         files =             libDotCabalFiles <> exeDotCabalFiles <> testDotCabalFiles <>
src/Stack/PackageDump.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-} module Stack.PackageDump     ( Line     , eachSection@@ -13,8 +14,6 @@     , conduitDumpPackage     , ghcPkgDump     , ghcPkgDescribe-    , InstalledCache-    , InstalledCacheEntry (..)     , newInstalledCache     , loadInstalledCache     , saveInstalledCache@@ -34,7 +33,6 @@ import           Control.Monad.Trans.Control import           Data.Attoparsec.Args import           Data.Attoparsec.Text as P-import           Data.Binary.VersionTagged import           Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Conduit.Text as CT@@ -45,36 +43,23 @@ import           Data.Maybe (catMaybes, listToMaybe) import           Data.Maybe.Extra (mapMaybeM) import qualified Data.Set as Set-import qualified Data.Text as T+import           Data.Store.VersionTagged import           Data.Text (Text)+import qualified Data.Text as T import           Data.Typeable (Typeable)-import           GHC.Generics (Generic) import           Path-import           Path.IO (ensureDir) import           Path.Extra (toFilePathNoTrailingSep) import           Prelude -- Fix AMP warning import           Stack.GhcPkg-import           Stack.Types+import           Stack.Types.Compiler+import           Stack.Types.GhcPkgId+import           Stack.Types.PackageDump+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName+import           Stack.Types.Version import           System.Directory (getDirectoryContents, doesFileExist) import           System.Process.Read --- | Cached information on whether package have profiling libraries and haddocks.-newtype InstalledCache = InstalledCache (IORef InstalledCacheInner)-newtype InstalledCacheInner = InstalledCacheInner (Map GhcPkgId InstalledCacheEntry)-    deriving (Binary, NFData, Generic)-instance HasStructuralInfo InstalledCacheInner-instance HasSemanticVersion InstalledCacheInner---- | Cached information on whether a package has profiling libraries and haddocks.-data InstalledCacheEntry = InstalledCacheEntry-    { installedCacheProfiling :: !Bool-    , installedCacheHaddock :: !Bool-    , installedCacheIdent :: !PackageIdentifier }-    deriving (Eq, Generic)-instance Binary InstalledCacheEntry-instance HasStructuralInfo InstalledCacheEntry-instance NFData InstalledCacheEntry- -- | 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)@@ -127,16 +112,16 @@  -- | Load a @InstalledCache@ from disk, swallowing any errors and returning an -- empty cache.-loadInstalledCache :: (MonadLogger m, MonadIO m) => Path Abs File -> m InstalledCache+loadInstalledCache :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+                   => Path Abs File -> m InstalledCache loadInstalledCache path = do-    m <- taggedDecodeOrLoad path (return $ InstalledCacheInner Map.empty)+    m <- $(versionedDecodeOrLoad installedCacheVC) path (return $ InstalledCacheInner Map.empty)     liftIO $ InstalledCache <$> newIORef m  -- | Save a @InstalledCache@ to disk-saveInstalledCache :: MonadIO m => Path Abs File -> InstalledCache -> m ()-saveInstalledCache path (InstalledCache ref) = liftIO $ do-    ensureDir (parent path)-    readIORef ref >>= taggedEncodeFile path+saveInstalledCache :: (MonadLogger m, MonadIO m) => Path Abs File -> InstalledCache -> m ()+saveInstalledCache path (InstalledCache ref) =+    liftIO (readIORef ref) >>= $(versionedEncodeFile installedCacheVC) path  -- | Prune a list of possible packages down to those whose dependencies are met. --
src/Stack/PackageIndex.hs view
@@ -33,12 +33,10 @@ import qualified Control.Monad.Catch as C import           Control.Monad.IO.Class (MonadIO, liftIO) import           Control.Monad.Logger                  (MonadLogger, logDebug,-                                                        logInfo, logWarn)+                                                        logInfo, logWarn, logError) import           Control.Monad.Reader (asks) import           Control.Monad.Trans.Control- import           Data.Aeson.Extended-import           Data.Binary.VersionTagged import qualified Data.ByteString.Lazy as L import           Data.Conduit (($$), (=$)) import           Data.Conduit.Binary                   (sinkHandle,@@ -49,33 +47,32 @@ import           Data.Int (Int64) 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.Monoid+import           Data.Store.Version+import           Data.Store.VersionTagged+import           Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import           Data.Text (Text) import qualified Data.Text as T import           Data.Text.Unsafe (unsafeTail)- import           Data.Traversable (forM)- import           Data.Typeable (Typeable)- import           Network.HTTP.Download-import           Path                                  (mkRelDir, parent,-                                                        parseRelDir, toFilePath,-                                                        parseAbsFile, (</>))+import           Path (mkRelDir, mkRelFile, parent, parseRelDir, toFilePath, parseAbsFile, (</>)) import           Path.IO import           Prelude -- Fix AMP warning-import           Stack.Types+import           Stack.Types.Config+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageIndex+import           Stack.Types.PackageName import           Stack.Types.StackT+import           Stack.Types.Version import           System.FilePath (takeBaseName, (<.>))-import           System.IO                             (IOMode (ReadMode, WriteMode),-                                                        withBinaryFile)-import           System.Process.Read         (EnvOverride,-                                              doesExecutableExist, readInNull,-                                              tryProcessStdout)-import           System.Process.Run          (Cmd(..), callProcessInheritStderrStdout)-import           Data.Streaming.Process      (ProcessExitedUnsuccessfully(..))+import           System.IO (IOMode (ReadMode, WriteMode), withBinaryFile)+import           System.Process.Read (EnvOverride, ReadProcessException(..), doesExecutableExist, readProcessNull, tryProcessStdout)+import           System.Process.Run (Cmd(..), callProcessInheritStderrStdout)+import           System.Exit (exitFailure)  -- | Populate the package index caches and return them. populateCache@@ -242,8 +239,6 @@                   ["clone"                   ,T.unpack gitUrl                   ,toFilePath repoName-                  ,"--depth"-                  ,"1"                   ,"-b" --                   ,"display"]             sDir <- configPackageIndexRoot indexName'@@ -253,28 +248,39 @@                 acfDir = suDir </> repoName             repoExists <- doesDirExist acfDir             unless repoExists-                   (readInNull suDir "git" menv cloneArgs Nothing)+                   (readProcessNull (Just suDir) menv "git" cloneArgs)+            isShallow <- doesFileExist $ acfDir </> $(mkRelDir ".git") </> $(mkRelFile "shallow")+            when isShallow $ do+              $logWarn "Shallow package index repo detected, transitioning to a full clone..."+              (readProcessNull (Just acfDir) menv "git" ["fetch", "--unshallow"])             $logSticky "Fetching package index ..."             let runFetch = callProcessInheritStderrStdout-                    (Cmd (Just acfDir) "git" menv ["fetch","--tags","--depth=1"])+                    (Cmd (Just acfDir) "git" menv ["fetch","--tags"])             runFetch `C.catch` \(ex :: ProcessExitedUnsuccessfully) -> do                 -- we failed, so wipe the directory and try again, see #1418                 $logWarn (T.pack (show ex))                 $logStickyDone "Failed to fetch package index, retrying."                 removeDirRecur acfDir-                readInNull suDir "git" menv cloneArgs Nothing+                readProcessNull (Just suDir) menv "git" cloneArgs                 $logSticky "Fetching package index ..."                 runFetch             $logStickyDone "Fetched package index." -            when (indexGpgVerify index)-                (readInNull acfDir "git" menv ["tag","-v","current-hackage"]-                    (Just (T.unlines ["Signature verification failed. "-                                     ,"Please ensure you've set up your"-                                     ,"GPG keychain to accept the D6CF60FD signing key."-                                     ,"For more information, see:"-                                     ,"https://github.com/fpco/stackage-update#readme"])))-+            when (indexGpgVerify index) $ do+                 result <- C.try $ readProcessNull (Just acfDir) menv "git" ["tag","-v","current-hackage"]+                 case result of+                     Left ex -> do+                         $logError (T.pack (show ex))+                         case ex of+                             ReadProcessException{} -> $logError $ T.unlines+                                 ["Signature verification failed. "+                                 ,"Please ensure you've set up your"+                                 ,"GPG keychain to accept the D6CF60FD signing key."+                                 ,"For more information, see:"+                                 ,"https://github.com/fpco/stackage-update#readme"]+                             _ -> return ()+                         liftIO exitFailure+                     Right () -> return ()             -- generate index archive when commit id differs from cloned repo             tarId <- getTarCommitId (toFilePath tarFile)             cloneId <- getCloneCommitId acfDir@@ -295,9 +301,8 @@          deleteCache indexName'          $logDebug ("Exporting a tarball to " <> (T.pack . toFilePath) tarFile)          let tarFileTmp = toFilePath tarFile ++ ".tmp"-         readInNull acfDir-             "git" menv ["archive","--format=tar","-o",tarFileTmp,"current-hackage"]-             Nothing+         readProcessNull (Just acfDir) menv+             "git" ["archive","--format=tar","-o",tarFileTmp,"current-hackage"]          tarFileTmpPath <- parseAbsFile tarFileTmp          renameFile tarFileTmpPath tarFile @@ -309,7 +314,7 @@                 -> Text -- ^ url                 -> m () updateIndexHTTP indexName' index url = do-    req <- parseUrl $ T.unpack url+    req <- parseRequest $ T.unpack url     $logInfo ("Downloading package index from " <> url)     gz <- configPackageIndexGz indexName'     tar <- configPackageIndex indexName'@@ -412,7 +417,11 @@         Nothing -> do             result <- liftM mconcat $ forM (configPackageIndices config) $ \index -> do                 fp <- configPackageIndexCache (indexName index)-                PackageCacheMap pis' <- taggedDecodeOrLoad fp $ liftM PackageCacheMap $ populateCache menv index+                PackageCacheMap pis' <-+                    $(versionedDecodeOrLoad (storeVersionConfig "pkg-v1" "aHzcZ6_w3rL6NtEJUqEfh6fcjAc="+                                             :: VersionConfig PackageCacheMap))+                    fp+                    (liftM PackageCacheMap (populateCache menv index))                 return (fmap (index,) pis')             liftIO $ writeIORef (configPackageCaches config) (Just result)             return result
+ src/Stack/Path.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Handy path information.+module Stack.Path+    ( path+    , pathParser+    ) where++import           Control.Monad.Catch+import           Control.Monad.Logger+import           Control.Monad.Reader+import           Control.Monad.Trans.Control+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 qualified Options.Applicative as OA+import           Path+import           Path.Extra+import           Stack.Constants+import           Stack.GhcPkg as GhcPkg+import           Stack.Types.Config+import qualified System.FilePath as FP+import           System.IO (stderr)+import           System.Process.Read (EnvOverride(eoPath))++-- | 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)+    => [Text]+    -> m ()+path keys =+    do -- We must use a BuildConfig from an EnvConfig to ensure that it contains the+       -- full environment info including GHC paths etc.+       bc <- asks (getBuildConfig . getEnvConfig)+       -- This is the modified 'bin-path',+       -- including the local GHC or MSYS if not configured to operate on+       -- global GHC.+       -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'.+       -- So it's not the *minimal* override path.+       menv <- getMinimalEnvOverride+       snap <- packageDatabaseDeps+       plocal <- packageDatabaseLocal+       extra <- packageDatabaseExtra+       global <- GhcPkg.getGlobalDB menv =<< getWhichCompiler+       snaproot <- installationRootDeps+       localroot <- installationRootLocal+       distDir <- distRelativeDir+       hpcDir <- hpcReportDir+       compiler <- getCompilerPath =<< getWhichCompiler+       let deprecated = filter ((`elem` keys) . fst) deprecatedPathKeys+       liftIO $ forM_ deprecated $ \(oldOption, newOption) -> T.hPutStrLn stderr $ T.unlines+           [ ""+           , "'--" <> oldOption <> "' will be removed in a future release."+           , "Please use '--" <> newOption <> "' instead."+           , ""+           ]+       forM_+           -- filter the chosen paths in flags (keys),+           -- or show all of them if no specific paths chosen.+           (filter+                (\(_,key,_) ->+                      (null keys && key /= T.pack deprecatedStackRootOptionName) || elem key keys)+                paths)+           (\(_,key,path') ->+                 liftIO $ T.putStrLn+                     -- If a single path type is requested, output it directly.+                     -- Otherwise, name all the paths.+                     ((if length keys == 1+                          then ""+                          else key <> ": ") <>+                      path'+                          (PathInfo+                               bc+                               menv+                               snap+                               plocal+                               global+                               snaproot+                               localroot+                               distDir+                               hpcDir+                               extra+                               compiler)))++pathParser :: OA.Parser [Text]+pathParser =+    mapMaybeA+        (\(desc,name,_) ->+             OA.flag Nothing+                     (Just name)+                     (OA.long (T.unpack name) <>+                      OA.help desc))+        paths++-- | Passed to all the path printers as a source of info.+data PathInfo = PathInfo+    { piBuildConfig  :: BuildConfig+    , piEnvOverride  :: EnvOverride+    , piSnapDb       :: Path Abs Dir+    , piLocalDb      :: Path Abs Dir+    , piGlobalDb     :: Path Abs Dir+    , piSnapRoot     :: Path Abs Dir+    , piLocalRoot    :: Path Abs Dir+    , piDistDir      :: Path Rel Dir+    , piHpcDir       :: Path Abs Dir+    , piExtraDbs     :: [Path Abs Dir]+    , piCompiler     :: Path Abs File+    }++-- | The paths of interest to a user. The first tuple string is used+-- for a description that the optparse flag uses, and the second+-- string as a machine-readable key and also for @--foo@ flags. The user+-- can choose a specific path to list like @--stack-root@. But+-- really it's mainly for the documentation aspect.+--+-- When printing output we generate @PathInfo@ and pass it to the+-- function to generate an appropriate string.  Trailing slashes are+-- removed, see #506+paths :: [(String, Text, PathInfo -> Text)]+paths =+    [ ( "Global stack root directory"+      , T.pack stackRootOptionName+      , T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig )+    , ( "Project root (derived from stack.yaml file)"+      , "project-root"+      , T.pack . toFilePathNoTrailingSep . bcRoot . piBuildConfig )+    , ( "Configuration location (where the stack.yaml file is)"+      , "config-location"+      , T.pack . toFilePath . bcStackYaml . piBuildConfig )+    , ( "PATH environment variable"+      , "bin-path"+      , T.pack . intercalate [FP.searchPathSeparator] . eoPath . piEnvOverride )+    , ( "Install location for GHC and other core tools"+      , "programs"+      , T.pack . toFilePathNoTrailingSep . configLocalPrograms . bcConfig . piBuildConfig )+    , ( "Compiler binary (e.g. ghc)"+      , "compiler-exe"+      , T.pack . toFilePath . piCompiler )+    , ( "Directory containing the compiler binary (e.g. ghc)"+      , "compiler-bin"+      , T.pack . toFilePathNoTrailingSep . parent . piCompiler )+    , ( "Local bin dir where stack installs executables (e.g. ~/.local/bin)"+      , "local-bin"+      , T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig )+    , ( "Extra include directories"+      , "extra-include-dirs"+      , T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraIncludeDirs . bcConfig . piBuildConfig )+    , ( "Extra library directories"+      , "extra-library-dirs"+      , T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraLibDirs . bcConfig . piBuildConfig )+    , ( "Snapshot package database"+      , "snapshot-pkg-db"+      , T.pack . toFilePathNoTrailingSep . piSnapDb )+    , ( "Local project package database"+      , "local-pkg-db"+      , T.pack . toFilePathNoTrailingSep . piLocalDb )+    , ( "Global package database"+      , "global-pkg-db"+      , T.pack . toFilePathNoTrailingSep . piGlobalDb )+    , ( "GHC_PACKAGE_PATH environment variable"+      , "ghc-package-path"+      , \pi' -> mkGhcPackagePath True (piLocalDb pi') (piSnapDb pi') (piExtraDbs pi') (piGlobalDb pi'))+    , ( "Snapshot installation root"+      , "snapshot-install-root"+      , T.pack . toFilePathNoTrailingSep . piSnapRoot )+    , ( "Local project installation root"+      , "local-install-root"+      , T.pack . toFilePathNoTrailingSep . piLocalRoot )+    , ( "Snapshot documentation root"+      , "snapshot-doc-root"+      , \pi' -> T.pack (toFilePathNoTrailingSep (piSnapRoot pi' </> docDirSuffix)))+    , ( "Local project documentation root"+      , "local-doc-root"+      , \pi' -> T.pack (toFilePathNoTrailingSep (piLocalRoot pi' </> docDirSuffix)))+    , ( "Dist work directory"+      , "dist-dir"+      , T.pack . toFilePathNoTrailingSep . piDistDir )+    , ( "Where HPC reports and tix files are stored"+      , "local-hpc-root"+      , T.pack . toFilePathNoTrailingSep . piHpcDir )+    , ( "DEPRECATED: Use '--local-bin' instead"+      , "local-bin-path"+      , T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig )+    , ( "DEPRECATED: Use '--programs' instead"+      , "ghc-paths"+      , T.pack . toFilePathNoTrailingSep . configLocalPrograms . bcConfig . piBuildConfig )+    , ( "DEPRECATED: Use '--" <> stackRootOptionName <> "' instead"+      , T.pack deprecatedStackRootOptionName+      , T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig )+    ]++deprecatedPathKeys :: [(Text, Text)]+deprecatedPathKeys =+    [ (T.pack deprecatedStackRootOptionName, T.pack stackRootOptionName)+    , ("ghc-paths", "programs")+    , ("local-bin-path", "local-bin")+    ]
+ src/Stack/PrettyPrint.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Stack.PrettyPrint+    (+      -- * Pretty printing functions+      displayPlain, displayAnsiIfPossible+      -- * Logging based on pretty-print typeclass+    , prettyDebug, prettyInfo, prettyWarn, prettyError+      -- * Color utils+      -- | These are preferred to colors directly, so that we can+      -- encourage consistency of color meanings.+    , errorRed, goodGreen, shellMagenta+    , displayTargetPkgId, displayCurrentPkgId, displayErrorPkgId+      -- * Re-exports from "Text.PrettyPrint.Leijen.Extended"+    , Display(..), AnsiDoc, AnsiAnn(..), HasAnsiAnn(..), Doc+    , nest, line, linebreak, group, softline, softbreak+    , align, hang, indent, encloseSep+    , (<+>)+    , hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate+    , fill, fillBreak+    , enclose, squotes, dquotes, parens, angles, braces, brackets+    ) where++import           Control.Monad.Logger+import           Control.Monad.Reader+import           Data.String (fromString)+import qualified Data.Text as T+import           Language.Haskell.TH+import           Path+import           Stack.Types.Internal+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName+import           Stack.Types.Version+import           Text.PrettyPrint.Leijen.Extended++displayAnsiIfPossible+    :: (HasTerminal env, MonadReader env m, Display a, HasAnsiAnn (Ann a))+    => a -> m T.Text+displayAnsiIfPossible x = do+    useAnsi <- asks getAnsiTerminal+    return $ if useAnsi then displayAnsi x else displayPlain x++-- TODO: switch to using implicit callstacks once 7.8 support is dropped++prettyDebug :: Q Exp+prettyDebug = do+    loc <- location+    [e| monadLoggerLog loc "" LevelDebug <=< displayAnsiIfPossible |]++prettyInfo :: Q Exp+prettyInfo = do+    loc <- location+    [e| monadLoggerLog loc "" LevelInfo <=< displayAnsiIfPossible |]++prettyWarn :: Q Exp+prettyWarn = do+    loc <- location+    [e| monadLoggerLog loc "" LevelWarn <=< displayAnsiIfPossible |]++prettyError :: Q Exp+prettyError = do+    loc <- location+    [e| monadLoggerLog loc "" LevelError <=< displayAnsiIfPossible |]++errorRed :: AnsiDoc -> AnsiDoc+errorRed = dullred++goodGreen :: AnsiDoc -> AnsiDoc+goodGreen = green++shellMagenta :: AnsiDoc -> AnsiDoc+shellMagenta = magenta++displayTargetPkgId :: PackageIdentifier -> AnsiDoc+displayTargetPkgId = cyan . display++displayCurrentPkgId :: PackageIdentifier -> AnsiDoc+displayCurrentPkgId = yellow . display++displayErrorPkgId :: PackageIdentifier -> AnsiDoc+displayErrorPkgId = errorRed . display++instance Display PackageName where+    display = fromString . packageNameString++instance Display PackageIdentifier where+    display = fromString . packageIdentifierString++instance Display Version where+    display = fromString . versionString++instance Display (Path b File) where+    display = bold . white . fromString . toFilePath++instance Display (Path b Dir) where+    display = bold . blue . fromString . toFilePath
+ src/Stack/Runners.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Utilities for running stack commands.+module Stack.Runners+    ( withGlobalConfigAndLock+    , withConfigAndLock+    , withMiniConfigAndLock+    , withBuildConfigAndLock+    , withBuildConfig+    , withBuildConfigExt+    , loadConfigWithOpts+    , loadCompilerVersion+    , withUserFileLock+    , 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           Network.HTTP.Client+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.Config+import           Stack.Types.StackT+import           System.Environment (getEnvironment)+import           System.IO+import           System.FileLock++loadCompilerVersion :: Manager+                    -> GlobalOpts+                    -> LoadConfig (StackLoggingT IO)+                    -> IO CompilerVersion+loadCompilerVersion manager go lc = do+    bconfig <- runStackLoggingTGlobal manager go $+      lcLoadBuildConfig lc (globalCompiler go)+    return $ bcWantedCompiler bconfig++-- | Enforce mutual exclusion of every action running via this+-- function, on this path, on this users account.+--+-- A lock file is created inside the given directory.  Currently,+-- stack uses locks per-snapshot.  In the future, stack may refine+-- this to an even more fine-grain locking approach.+--+withUserFileLock :: (MonadBaseControl IO m, MonadIO m)+                 => GlobalOpts+                 -> Path Abs Dir+                 -> (Maybe FileLock -> m a)+                 -> m a+withUserFileLock go@GlobalOpts{} dir act = do+    env <- liftIO getEnvironment+    let toLock = lookup "STACK_LOCK" env == Just "true"+    if toLock+        then do+            let lockfile = $(mkRelFile "lockfile")+            let pth = dir </> lockfile+            ensureDir dir+            -- Just in case of asynchronous exceptions, we need to be careful+            -- when using tryLockFile here:+            EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive)+                       (maybe (return ()) (liftIO . unlockFile))+                       (\fstTry ->+                        case fstTry of+                          Just lk -> EL.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+                                            when chatter $+                                              liftIO $ hPutStrLn stderr "Lock acquired, proceeding."+                                            act $ Just lk))+        else act Nothing++withConfigAndLock+    :: GlobalOpts+    -> StackT Config IO ()+    -> IO ()+withConfigAndLock go@GlobalOpts{..} inner = do+    (manager, lc) <- loadConfigWithOpts go+    withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk ->+        runStackTGlobal manager (lcConfig lc) go $+            Docker.reexecWithOptionalContainer+                (lcProjectRoot lc)+                Nothing+                (runStackTGlobal manager (lcConfig lc) go inner)+                Nothing+                (Just $ munlockFile lk)++-- | Loads global config, ignoring any configuration which would be+-- loaded due to $PWD.+withGlobalConfigAndLock+    :: GlobalOpts+    -> StackT Config IO ()+    -> IO ()+withGlobalConfigAndLock go@GlobalOpts{..} inner = do+    manager <- newTLSManager+    lc <- runStackLoggingTGlobal manager go $+        loadConfigMaybeProject globalConfigMonoid Nothing Nothing+    withUserFileLock go (configStackRoot $ lcConfig lc) $ \_lk ->+        runStackTGlobal manager (lcConfig lc) go inner++-- For now the non-locking version just unlocks immediately.+-- That is, there's still a serialization point.+withBuildConfig+    :: GlobalOpts+    -> StackT EnvConfig IO ()+    -> IO ()+withBuildConfig go inner =+    withBuildConfigAndLock go (\lk -> do munlockFile lk+                                         inner)++withBuildConfigAndLock+    :: GlobalOpts+    -> (Maybe FileLock -> StackT EnvConfig IO ())+    -> IO ()+withBuildConfigAndLock go inner =+    withBuildConfigExt go Nothing inner Nothing++withBuildConfigExt+    :: GlobalOpts+    -> Maybe (StackT Config IO ())+    -- ^ 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 ())+    -- ^ Action that uses the build config.  If Docker is enabled for builds,+    -- this will be run in a Docker container.+    -> Maybe (StackT Config IO ())+    -- ^ 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 go@GlobalOpts{..} mbefore inner mafter = do+    (manager, lc) <- loadConfigWithOpts go++    withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk0 -> do+      -- A local bit of state for communication between callbacks:+      curLk <- newIORef lk0+      let inner' lk =+            -- Locking policy:  This is only used for build commands, which+            -- only need to lock the snapshot, not the global lock.  We+            -- trade in the lock here.+            do dir <- installationRootDeps+               -- Hand-over-hand locking:+               withUserFileLock go dir $ \lk2 -> do+                 liftIO $ writeIORef curLk lk2+                 liftIO $ munlockFile lk+                 $logDebug "Starting to execute command inside EnvConfig"+                 inner lk2++      let inner'' lk = do+              bconfig <- runStackLoggingTGlobal manager go $+                  lcLoadBuildConfig lc globalCompiler+              envConfig <-+                 runStackTGlobal+                     manager bconfig go+                     (setupEnv Nothing)+              runStackTGlobal+                  manager+                  envConfig+                  go+                  (inner' lk)++      let getCompilerVersion = loadCompilerVersion manager go lc+      runStackTGlobal manager (lcConfig lc) go $+        Docker.reexecWithOptionalContainer+                 (lcProjectRoot lc)+                 mbefore+                 (runStackTGlobal manager (lcConfig lc) go $+                    Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (inner'' lk0))+                 mafter+                 (Just $ liftIO $+                      do lk' <- readIORef curLk+                         munlockFile lk')++-- | Load the configuration with a manager. Convenience function used+-- throughout this module.+loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO))+loadConfigWithOpts go@GlobalOpts{..} = do+    manager <- newTLSManager+    mstackYaml <- forM globalStackYaml resolveFile'+    lc <- runStackLoggingTGlobal manager go $ do+        lc <- loadConfig globalConfigMonoid globalResolver mstackYaml+        -- If we have been relaunched in a Docker container, perform in-container initialization+        -- (switch UID, etc.).  We do this after first loading the configuration since it must+        -- happen ASAP but needs a configuration.+        case globalDockerEntrypoint of+            Just de -> Docker.entrypoint (lcConfig lc) de+            Nothing -> return ()+        return lc+    return (manager,lc)++withMiniConfigAndLock+    :: GlobalOpts+    -> StackT MiniConfig IO ()+    -> IO ()+withMiniConfigAndLock go@GlobalOpts{..} inner = do+    manager <- newTLSManager+    miniConfig <- runStackLoggingTGlobal manager go $ do+        lc <- loadConfigMaybeProject globalConfigMonoid globalResolver Nothing+        loadMiniConfig manager (lcConfig lc)+    runStackTGlobal manager miniConfig go inner++-- | Unlock a lock file, if the value is Just+munlockFile :: MonadIO m => Maybe FileLock -> m ()+munlockFile Nothing = return ()+munlockFile (Just lk) = liftIO $ unlockFile lk
src/Stack/SDist.hs view
@@ -55,7 +55,12 @@ import           Stack.Build.Target import           Stack.Constants import           Stack.Package-import           Stack.Types+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.Internal import           System.Directory (getModificationTime, getPermissions) import qualified System.FilePath as FP@@ -108,7 +113,8 @@         packFile fp             | tweakCabal && isCabalFp fp = do                 lbs <- getCabalLbs pvpBounds $ toFilePath cabalfp-                return $ Tar.fileEntry (tarPath False fp) lbs+                currTime <- liftIO getPOSIXTime -- Seconds from UNIX epoch+                return $ (Tar.fileEntry (tarPath False fp) lbs) { Tar.entryTime = floor currTime }             | otherwise = packWith packFileEntry False fp         isCabalFp fp = toFilePath pkgDir FP.</> fp == toFilePath cabalfp         tarName = pkgId FP.<.> "tar.gz"
src/Stack/Setup.hs view
@@ -1,16 +1,15 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-} -- ghc < 7.10 {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE PackageImports        #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CPP #-}  module Stack.Setup   ( setupEnv@@ -22,74 +21,85 @@   , removeHaskellEnvVars   ) where -import           Control.Applicative-import           Control.Exception.Enclosed (catchIO, tryAny)-import           Control.Monad (liftM, when, join, void, unless)-import           Control.Monad.Catch-import           Control.Monad.IO.Class (MonadIO, liftIO)-import           Control.Monad.Logger-import           Control.Monad.Reader (MonadReader, ReaderT (..), asks)-import           Control.Monad.State (get, put, modify)-import           Control.Monad.Trans.Control+import              Control.Applicative+import              Control.Concurrent.Async.Lifted (Concurrently(..))+import              Control.Exception.Enclosed (catchIO, tryAny)+import              Control.Monad (liftM, when, join, void, unless)+import              Control.Monad.Catch+import              Control.Monad.IO.Class (MonadIO, liftIO)+import              Control.Monad.Logger+import              Control.Monad.Reader (MonadReader, ReaderT (..), asks)+import              Control.Monad.State (get, put, modify)+import              Control.Monad.Trans.Control import "cryptohash" Crypto.Hash (SHA1(SHA1))-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.Lift (evalStateC)-import qualified Data.Conduit.List as CL-import           Data.Either-import           Data.Foldable hiding (concatMap, or, maximum)-import           Data.IORef-import           Data.IORef.RunOnce (runOnce)-import           Data.List hiding (concat, elem, maximumBy, 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.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, Arch (..), Platform (..))-import qualified Distribution.System as Cabal-import           Distribution.Text (simpleParse)-import           Lens.Micro (set)-import           Network.HTTP.Client.Conduit-import           Network.HTTP.Download.Verified-import           Path-import           Path.Extra (toFilePathNoTrailingSep)-import           Path.IO hiding (findExecutable)-import qualified Paths_stack as Meta-import           Prelude hiding (concat, elem, any) -- Fix AMP warning-import           Safe (readMay)-import           Stack.Build (build)-import           Stack.Config (resolvePackageEntry, loadConfig)-import           Stack.Constants (distRelativeDir, stackProgName)-import           Stack.Exec (defaultEnvSettings)-import           Stack.Fetch-import           Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath)-import           Stack.Setup.Installed-import           Stack.Types-import           Stack.Types.Internal (HasTerminal, HasReExec, HasLogLevel, envConfigBuildOpts, buildOptsInstallExes)-import           Stack.Types.StackT-import qualified System.Directory as D-import           System.Environment (getExecutablePath)-import           System.Exit (ExitCode (ExitSuccess))-import           System.FilePath (searchPathSeparator)-import qualified System.FilePath as FP-import           System.Process (rawSystem)-import           System.Process.Read-import           System.Process.Run (runCmd, Cmd(..))-import           Text.Printf (printf)+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.Lift (evalStateC)+import qualified    Data.Conduit.List as CL+import              Data.Either+import              Data.Foldable hiding (concatMap, or, maximum)+import              Data.IORef+import              Data.IORef.RunOnce (runOnce)+import              Data.List hiding (concat, elem, maximumBy, 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 qualified    Distribution.System as Cabal+import              Distribution.Text (simpleParse)+import              Lens.Micro (set)+import              Network.HTTP.Client.Conduit (HasHttpManager, Manager, getHttpManager, parseUrlThrow,+                                                 responseBody, withResponse)+import              Network.HTTP.Download.Verified+import              Path+import              Path.Extra (toFilePathNoTrailingSep)+import              Path.IO hiding (findExecutable)+import qualified    Paths_stack as Meta+import              Prelude hiding (concat, elem, any) -- Fix AMP warning+import              Safe (headMay, readMay)+import              Stack.Build (build)+import              Stack.Config (resolvePackageEntry, loadConfig)+import              Stack.Constants (distRelativeDir, stackProgName)+import              Stack.Exec (defaultEnvSettings)+import              Stack.Fetch+import              Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath)+import              Stack.PrettyPrint+import              Stack.Setup.Installed+import              Stack.Types.Build+import              Stack.Types.Compiler+import              Stack.Types.Config+import              Stack.Types.Docker+import              Stack.Types.Internal (HasTerminal, HasReExec, HasLogLevel, envConfigBuildOpts, buildOptsInstallExes)+import              Stack.Types.PackageIdentifier+import              Stack.Types.PackageName+import              Stack.Types.StackT+import              Stack.Types.Version+import qualified    System.Directory as D+import              System.Environment (getExecutablePath)+import              System.Exit (ExitCode (..), exitFailure)+import              System.FilePath (searchPathSeparator)+import qualified    System.FilePath as FP+import              System.Process (rawSystem)+import              System.Process.Log (withProcessTimeLog)+import              System.Process.Read+import              System.Process.Run (runCmd, Cmd(..))+import              Text.Printf (printf)  -- | Default location of the stack-setup.yaml file defaultStackSetupYaml :: String@@ -207,17 +217,20 @@             , soptsGHCBindistURL = Nothing             } -    mghcBin <- ensureCompiler sopts+    (mghcBin, compilerBuild) <- ensureCompiler sopts      -- Modify the initial environment to include the GHC path, if a local GHC     -- is being used     menv0 <- getMinimalEnvOverride     env <- removeHaskellEnvVars              <$> augmentPathMap (maybe [] edBins mghcBin) (unEnvOverride menv0)-     menv <- mkEnvOverride platform env-    compilerVer <- getCompilerVersion menv wc-    cabalVer <- getCabalPkgVer menv wc++    (compilerVer, cabalVer, globaldb) <- runConcurrently $ (,,)+        <$> Concurrently (getCompilerVersion menv wc)+        <*> Concurrently (getCabalPkgVer menv wc)+        <*> Concurrently (getGlobalDB menv wc)+     $logDebug "Resolving package entries"     packages <- mapM         (resolvePackageEntry menv (bcRoot bconfig))@@ -226,21 +239,20 @@             { envConfigBuildConfig = bconfig             , envConfigCabalVersion = cabalVer             , envConfigCompilerVersion = compilerVer+            , envConfigCompilerBuild = compilerBuild             , envConfigPackages = Map.fromList $ concat packages             }      -- extra installation bin directories     mkDirs <- runReaderT extraBinDirs envConfig0     let mpath = Map.lookup "PATH" env-        mkDirs' = map toFilePath . mkDirs-    depsPath <- augmentPath (mkDirs' False) mpath-    localsPath <- augmentPath (mkDirs' True) mpath+    depsPath <- augmentPath (mkDirs False) mpath+    localsPath <- augmentPath (mkDirs True) mpath      deps <- runReaderT packageDatabaseDeps envConfig0     createDatabase menv wc deps     localdb <- runReaderT packageDatabaseLocal envConfig0     createDatabase menv wc localdb-    globaldb <- getGlobalDB menv wc     extras <- runReaderT packageDatabaseExtra envConfig0     let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb @@ -306,6 +318,7 @@             }         , envConfigCabalVersion = cabalVer         , envConfigCompilerVersion = compilerVer+        , envConfigCompilerBuild = compilerBuild         , envConfigPackages = envConfigPackages envConfig0         } @@ -314,16 +327,16 @@ addIncludeLib (ExtraDirs _bins includes libs) config = config     { configExtraIncludeDirs = Set.union         (configExtraIncludeDirs config)-        (Set.fromList $ map T.pack includes)+        (Set.fromList includes)     , configExtraLibDirs = Set.union         (configExtraLibDirs config)-        (Set.fromList $ map T.pack libs)+        (Set.fromList libs)     }  -- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary ensureCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, HasGHCVariant env, MonadBaseControl IO m)                => SetupOpts-               -> m (Maybe ExtraDirs)+               -> m (Maybe ExtraDirs, CompilerBuild) ensureCompiler sopts = do     let wc = whichCompiler (soptsWantedCompiler sopts)     when (getGhcVersion (soptsWantedCompiler sopts) < $(mkVersion "7.8")) $ do@@ -354,7 +367,7 @@          -- If we need to install a GHC or MSYS, try to do so         -- Return the additional directory paths of GHC & MSYS.-    mtools <- if needLocal+    (mtools, compilerBuild) <- if needLocal         then do             getSetupInfo' <- runOnce (getSetupInfo (soptsStackSetupYaml sopts) =<< asks getHttpManager) @@ -364,17 +377,20 @@             -- Install GHC             ghcVariant <- asks getGHCVariant             config <- asks getConfig-            ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant)-            let installedCompiler =+            (installedCompiler, compilerBuild) <-                     case wc of-                        Ghc -> getInstalledTool installed ghcPkgName (isWanted . GhcVersion)-                        Ghcjs -> getInstalledGhcjs installed isWanted+                        Ghc -> do+                            ghcBuild <- getGhcBuild menv0+                            ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)+                            return (getInstalledTool installed ghcPkgName (isWanted . GhcVersion), ghcBuild)+                        Ghcjs -> return (getInstalledGhcjs installed isWanted, CompilerBuildStandard)             compilerTool <- case installedCompiler of                 Just tool -> return tool                 Nothing                     | soptsInstallIfMissing sopts -> do                         si <- getSetupInfo'                         downloadAndInstallCompiler+                            compilerBuild                             si                             (soptsWantedCompiler sopts)                             (soptsCompilerCheck sopts)@@ -384,6 +400,7 @@                             msystem                             (soptsWantedCompiler sopts, expectedArch)                             ghcVariant+                            compilerBuild                             (soptsCompilerCheck sopts)                             (soptsStackYaml sopts)                             (fromMaybe@@ -412,8 +429,8 @@                                 return Nothing                 _ -> return Nothing -            return $ Just (compilerTool, mmsys2Tool)-        else return Nothing+            return (Just (compilerTool, mmsys2Tool), compilerBuild)+        else return (Nothing, CompilerBuildStandard)      mpaths <- case mtools of         Nothing -> return Nothing@@ -443,9 +460,85 @@      when (soptsSanityCheck sopts) $ sanityCheck menv wc -    return mpaths+    return (mpaths, compilerBuild) --- Ensure Docker container-compatible 'stack' executable is downloaded+-- | Determine which GHC build to use dependong on which shared libraries are available+-- on the system.+getGhcBuild+    :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m, HasPlatform env, MonadReader env m)+    => EnvOverride -> m CompilerBuild+getGhcBuild menv = do++    -- TODO: a more reliable, flexible, and data driven approach would be to actually download small+    -- "test" executables (from setup-info) that link to the same gmp/tinfo versions+    -- that GHC does (i.e. built in same environment as the GHC bindist). The algorithm would go+    -- something like this:+    --+    -- check for previous 'uname -a'/`ldconfig -p` plus compiler version/variant in cache+    -- if cached, then use that as suffix+    -- otherwise:+    --     download setup-info+    --     go through all with right prefix for os/version/variant+    --     first try "standard" (no extra suffix), then the rest+    --         download "compatibility check" exe if not already downloaded+    --         try running it+    --         if successful, then choose that+    --             cache compiler suffix with the uname -a and ldconfig -p output hash plus compiler version+    --+    -- Of course, could also try to make a static GHC bindist instead of all this rigamarole.++    platform <- asks getPlatform+    case platform of+        Platform _ 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" $+                "/sbin:/usr/sbin" <>+                (maybe "" (":" <>) $ Map.lookup "PATH" (eoTextMap menv))+            eldconfigOut <- tryProcessStdout Nothing sbinEnv "ldconfig" ["-p"]+            let firstWords = case eldconfigOut of+                    Right ldconfigOut -> mapMaybe (headMay . 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")+                        return True+#ifndef WINDOWS+                    -- (mkAbsDir "/usr/lib") fails to compile on Windows, thus the CPP+                    | otherwise = do+                        -- This is a workaround for the fact that libtinfo.so.6 doesn't appear in+                        -- the 'ldconfig -p' output on Arch even when it exists.+                        -- There doesn't seem to be an easy way to get the true list of directories+                        -- to scan for shared libs, but this works for our particular case.+                        e <- doesFileExist ($(mkAbsDir "/usr/lib") </> lib)+                        if e+                            then $logDebug ("Found shared library " <> libT <> " in /usr/lib")+                            else $logDebug ("Did not find shared library " <> libT)+                        return e+#endif+                  where+                    libT = T.pack (toFilePath lib)+            hastinfo5 <- checkLib $(mkRelFile "libtinfo.so.5")+            hastinfo6 <- checkLib $(mkRelFile "libtinfo.so.6")+            hasncurses6 <- checkLib $(mkRelFile "libncursesw.so.6")+            hasgmp5 <- checkLib $(mkRelFile "libgmp.so.10")+            hasgmp4 <- checkLib $(mkRelFile "libgmp.so.3")+            if  | hastinfo5 && hasgmp5 -> useBuild CompilerBuildStandard+                | hastinfo6 && hasgmp5 -> useBuild (CompilerBuildSpecialized "tinfo6")+                | hasncurses6 && hasgmp5 -> useBuild (CompilerBuildSpecialized "ncurses6")+                | hasgmp4 && hastinfo5 -> useBuild (CompilerBuildSpecialized "gmp4")+                | otherwise -> useBuild CompilerBuildStandard+        _ -> useBuild CompilerBuildStandard+  where+    useBuild CompilerBuildStandard = do+        $logDebug "Using standard GHC build"+        return (CompilerBuildStandard)+    useBuild (CompilerBuildSpecialized s) = do+        $logDebug ("Using " <> T.pack s <> " GHC build")+        return (CompilerBuildSpecialized s)++-- | Ensure Docker container-compatible 'stack' executable is downloaded ensureDockerStackExe     :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)     => Platform -> m (Path Abs File)@@ -467,7 +560,13 @@                    Just versions ->                        case Map.lookup stackVersion versions of                            Just x -> return x-                           Nothing -> throwM (DockerStackExeNotFound stackVersion osKey)+                           Nothing ->+                               case mapMaybe (matchMinor stackVersion) (Map.keys versions) of+                                   (v:_) ->+                                       case Map.lookup v versions of+                                           Just x -> return x+                                           Nothing ->  throwM (DockerStackExeNotFound v osKey)+                                   [] -> throwM (DockerStackExeNotFound stackVersion osKey)                    Nothing -> throwM (DockerStackExeNotFound stackVersion osKey)            _ <-                downloadAndInstallTool@@ -478,6 +577,11 @@                    installDockerStackExe            return ()     return stackExePath+  where+    matchMinor stackVersion v =+        if checkVersion MatchMinor stackVersion v+            then Just v+            else Nothing  -- | Install the newest version of Cabal globally upgradeCabal :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadMask m)@@ -536,7 +640,7 @@                     , "dir="                     , installRoot FP.</> name'                     ]-                args = ( "configure": map dirArgument (words "lib bin data doc") )+                args = "configure" : map dirArgument (words "lib bin data doc")             runCmd (Cmd (Just dir) setupExe menv args) Nothing             runCmd (Cmd (Just dir) setupExe menv ["build"]) Nothing             runCmd (Cmd (Just dir) setupExe menv ["install"]) Nothing@@ -584,7 +688,7 @@     loadSetupInfo (SetupInfoInline si) = return si     loadSetupInfo (SetupInfoFileOrURL urlOrFile) = do         bs <--            case parseUrl urlOrFile of+            case parseUrlThrow urlOrFile of                 Just req -> do                     bss <-                         liftIO $@@ -628,28 +732,34 @@     goodPackage (ToolGhcjs cv) = if goodVersion cv then Just cv else Nothing     goodPackage _ = Nothing -downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)+downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m)                        => Path Abs Dir                        -> SetupInfo                        -> DownloadInfo                        -> Tool-                       -> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> m ())+                       -> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> Path Abs Dir -> m ())                        -> m 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)+    ensureDir tempDir     unmarkInstalled programsDir tool-    installer si file at dir+    installer si file at tempDir dir     markInstalled programsDir tool+    ignoringAbsence (removeDirRecur tempDir)     return tool  downloadAndInstallCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)-                           => SetupInfo+                           => CompilerBuild+                           -> SetupInfo                            -> CompilerVersion                            -> VersionCheck                            -> Maybe String                            -> m Tool-downloadAndInstallCompiler si wanted@(GhcVersion{}) versionCheck mbindistURL = do+downloadAndInstallCompiler ghcBuild si wanted@GhcVersion{} versionCheck mbindistURL = do     ghcVariant <- asks getGHCVariant     (selectedVersion, downloadInfo) <- case mbindistURL of         Just bindistURL -> do@@ -662,7 +772,7 @@                 _ ->                     throwM WantedMustBeGHC         _ -> do-            ghcKey <- getGhcKey+            ghcKey <- getGhcKey ghcBuild             case Map.lookup ghcKey $ siGHCs si of                 Nothing -> throwM $ UnknownOSKey ghcKey                 Just pairs_ -> getWantedCompilerInfo ghcKey versionCheck wanted GhcVersion pairs_@@ -676,16 +786,19 @@         (case ghcVariant of             GHCStandard -> ""             v -> " (" <> T.pack (ghcVariantName v) <> ")") <>+        (case ghcBuild of+            CompilerBuildStandard -> ""+            b -> " (" <> T.pack (compilerBuildName b) <> ")") <>         " to an isolated location."     $logInfo "This will not interfere with any system-level installation."-    ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant)+    ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)     let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion     downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer-downloadAndInstallCompiler si wanted versionCheck _mbindistUrl = do+downloadAndInstallCompiler compilerBuild si wanted versionCheck _mbindistUrl = do     config <- asks getConfig     ghcVariant <- asks getGHCVariant-    case ghcVariant of-        GHCStandard -> return ()+    case (ghcVariant, compilerBuild) of+        (GHCStandard, CompilerBuildStandard) -> return ()         _ -> throwM GHCJSRequiresStandardVariant     (selectedVersion, downloadInfo) <- case Map.lookup "source" $ siGHCJSs si of         Nothing -> throwM $ UnknownOSKey "source"@@ -713,12 +826,12 @@         filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs_)  getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadCatch m)-          => m Text-getGhcKey = do+          => CompilerBuild -> m Text+getGhcKey ghcBuild = do     ghcVariant <- asks getGHCVariant     platform <- asks getPlatform     osKey <- getOSKey platform-    return $ osKey <> T.pack (ghcVariantSuffix ghcVariant)+    return $ osKey <> T.pack (ghcVariantSuffix ghcVariant) <> T.pack (compilerBuildSuffix ghcBuild)  getOSKey :: (MonadThrow m)          => Platform -> m Text@@ -734,10 +847,11 @@         Platform X86_64 Cabal.OpenBSD -> return "openbsd64"         Platform I386   Cabal.Windows -> return "windows32"         Platform X86_64 Cabal.Windows -> return "windows64"+        Platform Arm    Cabal.Linux   -> return "linux-armv7"         Platform arch os -> throwM $ UnsupportedSetupCombo os arch  downloadFromInfo-    :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)+    :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m)     => Path Abs Dir -> DownloadInfo -> Tool -> m (Path Abs File, ArchiveType) downloadFromInfo programsDir downloadInfo tool = do     at <-@@ -746,15 +860,30 @@             ".tar.bz2" -> return TarBz2             ".tar.gz" -> return TarGz             ".7z.exe" -> return SevenZ-            _ -> error $ "Unknown extension for url: " ++ T.unpack url+            _ -> fail $ "Unknown extension for url: " ++ url     relfile <- parseRelFile $ toolString tool ++ extension-    let path = programsDir </> relfile-    chattyDownload (T.pack (toolString tool)) downloadInfo path+    path <- case url of+        (parseUrlThrow -> Just _) -> do+            let path = programsDir </> relfile+            ensureDir programsDir+            chattyDownload (T.pack (toolString tool)) downloadInfo path+            return path+        (parseAbsFile -> Just path) -> do+            let DownloadInfo{downloadInfoContentLength=contentLength, downloadInfoSha1=sha1} =+                    downloadInfo+            when (isJust contentLength) $+                $logWarn ("`content-length` in not checked \n" <>+                          "and should not be specified when `url` is a file path")+            when (isJust sha1) $+                $logWarn ("`sha1` is not checked and \n" <>+                          "should not be specified when `url` is a file path")+            return path+        _ ->+            fail $ "`url` must be either an HTTP URL or absolute file path: " ++ url     return (path, at)   where-    url = downloadInfoUrl downloadInfo-    extension =-        loop $ T.unpack url+    url = T.unpack $ downloadInfoUrl downloadInfo+    extension = loop url       where         loop fp             | ext `elem` [".tar", ".bz2", ".xz", ".exe", ".7z", ".gz"] = loop fp' ++ ext@@ -768,60 +897,84 @@     | TarGz     | SevenZ -installGHCPosix :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)+installGHCPosix :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m, HasTerminal env)                 => Version                 -> SetupInfo                 -> Path Abs File                 -> ArchiveType                 -> Path Abs Dir+                -> Path Abs Dir                 -> m ()-installGHCPosix version _ archiveFile archiveType destDir = do+installGHCPosix version _ archiveFile archiveType tempDir destDir = do     platform <- asks getPlatform     menv0 <- getMinimalEnvOverride     menv <- mkEnvOverride platform (removeHaskellEnvVars (unEnvOverride menv0))     $logDebug $ "menv = " <> T.pack (show (unEnvOverride menv))-    zipTool' <-+    (zipTool', compOpt) <-         case archiveType of-            TarXz -> return "xz"-            TarBz2 -> return "bzip2"-            TarGz -> return "gzip"+            TarXz -> return ("xz", 'J')+            TarBz2 -> return ("bzip2", 'j')+            TarGz -> return ("gzip", 'z')             SevenZ -> error "Don't know how to deal with .7z files on non-Windows"+    -- Slight hack: OpenBSD's tar doesn't support xz.+    -- https://github.com/commercialhaskell/stack/issues/2283#issuecomment-237980986+    let tarDep =+          case (platform, archiveType) of+            (Platform _ Cabal.OpenBSD, TarXz) -> checkDependency "gtar"+            _ -> checkDependency "tar"     (zipTool, makeTool, tarTool) <- checkDependencies $ (,,)         <$> checkDependency zipTool'         <*> (checkDependency "gmake" <|> checkDependency "make")-        <*> checkDependency "tar"+        <*> tarDep      $logDebug $ "ziptool: " <> T.pack zipTool     $logDebug $ "make: " <> T.pack makeTool     $logDebug $ "tar: " <> T.pack tarTool -    withSystemTempDir "stack-setup" $ \root -> do-        dir <--            liftM (root </>) $-            parseRelDir $-            "ghc-" ++ versionString version+    dir <-+        liftM (tempDir </>) $+        parseRelDir $+        "ghc-" ++ versionString version -        $logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ root, " ..."]-        $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)-        readInNull root tarTool menv ["xf", toFilePath archiveFile] Nothing+    let runStep step wd cmd args = do+            result <- try (readProcessNull (Just wd) menv cmd args)+            case result of+                Right _ -> return ()+                Left ex -> do+                    $logError (T.pack (show (ex :: ReadProcessException)))+                    $prettyError $+                        hang 2+                          ("Error encountered while" <+> step <+> "GHC with" <> line <>+                           shellMagenta (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 <>+                           "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 "Configuring GHC ..."-        readInNull dir (toFilePath $ dir </> $(mkRelFile "configure"))-                   menv ["--prefix=" ++ toFilePath destDir] Nothing+    $logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ tempDir, " ..."]+    $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)+    runStep "unpacking" tempDir tarTool [compOpt : "xf", toFilePath archiveFile] -        $logSticky "Installing GHC ..."-        readInNull dir makeTool menv ["install"] Nothing+    $logSticky "Configuring GHC ..."+    runStep "configuring" dir (toFilePath $ dir </> $(mkRelFile "configure")) ["--prefix=" ++ toFilePath destDir] -        $logStickyDone $ "Installed GHC."-        $logDebug $ "GHC installed to " <> T.pack (toFilePath destDir)+    $logSticky "Installing GHC ..."+    runStep "installing" dir makeTool ["install"] +    $logStickyDone $ "Installed GHC."+    $logDebug $ "GHC installed to " <> T.pack (toFilePath destDir)+ installGHCJS :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)              => SetupInfo              -> Path Abs File              -> ArchiveType              -> Path Abs Dir+             -> Path Abs Dir              -> m ()-installGHCJS si archiveFile archiveType destDir = do+installGHCJS si archiveFile archiveType _tempDir destDir = do     platform <- asks getPlatform     menv0 <- getMinimalEnvOverride     -- This ensures that locking is disabled for the invocations of@@ -830,7 +983,7 @@     menv <- mkEnvOverride platform (removeLockVar (removeHaskellEnvVars (unEnvOverride menv0)))     $logDebug $ "menv = " <> T.pack (show (unEnvOverride menv)) -    -- NOTE: this is a bit of a hack - instead of using a temp+    -- NOTE: this is a bit of a hack - instead of using the temp     -- directory, leave the unpacked source tarball in the destination     -- directory. This way, the absolute paths in the wrapper scripts     -- will point to executables that exist in@@ -860,7 +1013,7 @@             return $ do                 ignoringAbsence (removeDirRecur destDir)                 ignoringAbsence (removeDirRecur unpackDir)-                readInNull destDir tarTool menv ["xf", toFilePath archiveFile] Nothing+                readProcessNull (Just destDir) menv tarTool ["xf", toFilePath archiveFile]                 innerDir <- expectSingleUnpackedDir archiveFile destDir                 renameDir innerDir unpackDir @@ -883,8 +1036,8 @@         _ -> return Nothing      $logSticky "Installing GHCJS (this will take a long time) ..."-    runInnerStackT ((set (envConfigBuildOpts.buildOptsInstallExes) True envConfig')) $-        (build (\_ -> return ()) Nothing defaultBuildOptsCLI)+    runInnerStackT (set (envConfigBuildOpts.buildOptsInstallExes) True envConfig') $+        build (\_ -> return ()) Nothing defaultBuildOptsCLI     -- Copy over *.options files needed on windows.     forM_ mwindowsInstallDir $ \dir -> do         (_, files) <- listDir (dir </> $(mkRelDir "bin"))@@ -901,19 +1054,19 @@     -> Path Abs File     -> ArchiveType     -> Path Abs Dir+    -> Path Abs Dir     -> m ()-installDockerStackExe _ archiveFile _ destDir = do+installDockerStackExe _ archiveFile _ _tempDir destDir = do     (_,tarTool) <-         checkDependencies $         (,) <$> checkDependency "gzip" <*> checkDependency "tar"     menv <- getMinimalEnvOverride     ensureDir destDir-    readInNull-        destDir-        tarTool+    readProcessNull+        (Just destDir)         menv+        tarTool         ["xf", toFilePath archiveFile, "--strip-components", "1"]-        Nothing  ensureGhcjsBooted :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadReader env m)                   => EnvOverride -> CompilerVersion -> Bool -> m ()@@ -1069,8 +1222,9 @@                   -> Path Abs File                   -> ArchiveType                   -> Path Abs Dir+                  -> Path Abs Dir                   -> m ()-installGHCWindows version si archiveFile archiveType destDir = do+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)@@ -1081,8 +1235,9 @@                   -> Path Abs File                   -> ArchiveType                   -> Path Abs Dir+                  -> Path Abs Dir                   -> m ()-installMsys2Windows osKey si archiveFile archiveType destDir = do+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 $@@ -1100,8 +1255,7 @@     platform <- asks getPlatform     menv0 <- getMinimalEnvOverride     newEnv0 <- modifyEnvOverride menv0 $ Map.insert "MSYSTEM" "MSYS"-    newEnv <- augmentPathMap [toFilePath $ destDir </> $(mkRelDir "usr")-                                                   </> $(mkRelDir "bin")]+    newEnv <- augmentPathMap [destDir </> $(mkRelDir "usr") </> $(mkRelDir "bin")]                              (unEnvOverride newEnv0)     menv <- mkEnvOverride platform newEnv     runCmd (Cmd (Just destDir) "sh" menv ["--login", "-c", "true"]) Nothing@@ -1168,6 +1322,7 @@         -> m (Path Abs Dir -> Path Abs File -> n ()) setup7z si = do     dir <- asks $ configLocalPrograms . getConfig+    ensureDir dir     let exe = dir </> $(mkRelFile "7z.exe")         dll = dir </> $(mkRelFile "7z.dll")     case (siSevenzDll si, siSevenzExe si) of@@ -1182,8 +1337,8 @@                         , "-y"                         , toFilePath archive                         ]-                $logProcessRun cmd args-                ec <- liftIO $ rawSystem cmd args+                ec <- $withProcessTimeLog cmd args $+                    liftIO $ rawSystem cmd args                 when (ec /= ExitSuccess)                     $ liftIO $ throwM (ProblemWhileDecompressing archive)         _ -> throwM SetupInfoMissingSevenz@@ -1195,7 +1350,7 @@                -> m () chattyDownload label downloadInfo path = do     let url = downloadInfoUrl downloadInfo-    req <- parseUrl $ T.unpack url+    req <- parseUrlThrow $ T.unpack url     $logSticky $ T.concat       [ "Preparing to download "       , label@@ -1348,7 +1503,7 @@     :: forall m env.        (MonadReader env m, HasPlatform env, MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m)     => EnvOverride -> CompilerVersion -> m (Map Text Text)-getUtf8EnvVars menv compilerVer = do+getUtf8EnvVars menv compilerVer =     if getGhcVersion compilerVer >= $(mkVersion "7.10.3")         -- GHC_CHARENC supported by GHC >=7.10.3         then return $ Map.singleton "GHC_CHARENC" "UTF-8"
src/Stack/Setup/Installed.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+ module Stack.Setup.Installed     ( getCompilerVersion     , markInstalled@@ -15,6 +17,7 @@     , ExtraDirs (..)     , extraDirs     , installDir+    , tempInstallDir     ) where  import           Control.Applicative@@ -35,10 +38,13 @@ import           GHC.Generics (Generic) import           Generics.Deriving.Monoid (mappenddefault, memptydefault) import           Path-import           Path.Extra (toFilePathNoTrailingSep) import           Path.IO import           Prelude hiding (concat, elem) -- Fix AMP warning-import           Stack.Types+import           Stack.Types.PackageIdentifier+import           Stack.Types.Compiler+import           Stack.Types.Config+import           Stack.Types.PackageName+import           Stack.Types.Version import           System.Process.Read  data Tool@@ -78,9 +84,10 @@               => Path Abs Dir               -> m [Tool] listInstalled programsPath = do-    ensureDir programsPath-    (_, files) <- listDir programsPath-    return $ mapMaybe toTool files+    doesDirExist programsPath >>= \case+        False -> return []+        True -> do (_, files) <- listDir programsPath+                   return $ mapMaybe toTool files   where     toTool fp = do         x <- T.stripSuffix ".installed" $ T.pack $ toFilePath $ filename fp@@ -117,44 +124,44 @@     dir <- installDir (configLocalPrograms config) tool     case (configPlatform config, toolNameString tool) of         (Platform _ Cabal.Windows, isGHC -> True) -> return mempty-            { edBins = goList+            { edBins =                 [ dir </> $(mkRelDir "bin")                 , dir </> $(mkRelDir "mingw") </> $(mkRelDir "bin")                 ]             }         (Platform Cabal.I386 Cabal.Windows, "msys2") -> return mempty-            { edBins = goList+            { edBins =                 [ dir </> $(mkRelDir "mingw32") </> $(mkRelDir "bin")                 , dir </> $(mkRelDir "usr") </> $(mkRelDir "bin")                 , dir </> $(mkRelDir "usr") </> $(mkRelDir "local") </> $(mkRelDir "bin")                 ]-            , edInclude = goList+            , edInclude =                 [ dir </> $(mkRelDir "mingw32") </> $(mkRelDir "include")                 ]-            , edLib = goList+            , edLib =                 [ dir </> $(mkRelDir "mingw32") </> $(mkRelDir "lib")                 ]             }         (Platform Cabal.X86_64 Cabal.Windows, "msys2") -> return mempty-            { edBins = goList+            { edBins =                 [ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "bin")                 , dir </> $(mkRelDir "usr") </> $(mkRelDir "bin")                 , dir </> $(mkRelDir "usr") </> $(mkRelDir "local") </> $(mkRelDir "bin")                 ]-            , edInclude = goList+            , edInclude =                 [ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "include")                 ]-            , edLib = goList+            , edLib =                 [ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "lib")                 ]             }         (_, isGHC -> True) -> return mempty-            { edBins = goList+            { edBins =                 [ dir </> $(mkRelDir "bin")                 ]             }         (_, isGHCJS -> True) -> return mempty-            { edBins = goList+            { edBins =                 [ dir </> $(mkRelDir "bin")                 ]             }@@ -162,14 +169,13 @@             $logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, toolName))             return mempty   where-    goList = map toFilePathNoTrailingSep     isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n     isGHCJS n = "ghcjs" == n  data ExtraDirs = ExtraDirs-    { edBins :: ![FilePath]-    , edInclude :: ![FilePath]-    , edLib :: ![FilePath]+    { edBins :: ![Path Abs Dir]+    , edInclude :: ![Path Abs Dir]+    , edLib :: ![Path Abs Dir]     } deriving (Show, Generic) instance Monoid ExtraDirs where     mempty = memptydefault@@ -181,4 +187,12 @@            -> m (Path Abs Dir) installDir programsDir tool = do     reldir <- parseRelDir $ toolString tool+    return $ programsDir </> reldir++tempInstallDir :: (MonadReader env m, MonadThrow m)+           => Path Abs Dir+           -> Tool+           -> m (Path Abs Dir)+tempInstallDir programsDir tool = do+    reldir <- parseRelDir $ toolString tool ++ ".temp"     return $ programsDir </> reldir
+ src/Stack/SetupCmd.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Install GHC/GHCJS and Cabal.+module Stack.SetupCmd+    ( setup+    , setupParser+    , SetupCmdOpts(..)+    ) where++import           Control.Applicative+import           Control.Monad.Catch+import           Control.Monad.IO.Class+import           Control.Monad.Logger+import           Control.Monad.Reader+import           Control.Monad.Trans.Control+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           Network.HTTP.Client+import           Path+import           Prelude -- silence redundant import warnings+import           Stack.Setup+import           Stack.Types.Compiler+import           Stack.Types.Config+import           Stack.Types.Internal+import           Stack.Types.Version++data SetupCmdOpts = SetupCmdOpts+    { scoCompilerVersion :: !(Maybe CompilerVersion)+    , scoForceReinstall  :: !Bool+    , scoUpgradeCabal    :: !Bool+    , scoStackSetupYaml  :: !String+    , scoGHCBindistURL   :: !(Maybe String)+    }++setupParser :: OA.Parser SetupCmdOpts+setupParser = SetupCmdOpts+    <$> OA.optional (OA.argument readVersion+            (OA.metavar "GHC_VERSION" <>+             OA.help ("Version of GHC to install, e.g. 7.10.2. " +++                      "The default is to install the version implied by the resolver.")))+    <*> OA.boolFlags False+            "reinstall"+            "reinstalling GHC, even if available (implies no-system-ghc)"+            OA.idm+    <*> OA.boolFlags False+            "upgrade-cabal"+            "installing the newest version of the Cabal library globally"+            OA.idm+    <*> OA.strOption+            ( OA.long "stack-setup-yaml"+           <> OA.help "Location of the main stack-setup.yaml file"+           <> OA.value defaultStackSetupYaml+           <> OA.showDefault )+    <*> OA.optional (OA.strOption+            (OA.long "ghc-bindist"+           <> OA.metavar "URL"+           <> OA.help "Alternate GHC binary distribution (requires custom --ghc-variant)"))+  where+    readVersion = do+        s <- OA.readerAsk+        case parseCompilerVersion ("ghc-" <> T.pack s) of+            Nothing ->+                case parseCompilerVersion (T.pack s) of+                    Nothing -> OA.readerError $ "Invalid version: " ++ s+                    Just x -> return x+            Just x -> return x++setup+    :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env,+        MonadBaseControl IO m, MonadMask m, HasHttpManager env,+        HasGHCVariant env, HasTerminal env, HasReExec env, HasLogLevel env)+    => SetupCmdOpts+    -> CompilerVersion+    -> VersionCheck+    -> Maybe (Path Abs File)+    -> m ()+setup SetupCmdOpts{..} wantedCompiler compilerCheck mstack = do+    Config{..} <- asks getConfig+    mpaths <- fst <$> ensureCompiler SetupOpts+        { soptsInstallIfMissing = True+        , soptsUseSystem = configSystemGHC && not scoForceReinstall+        , soptsWantedCompiler = wantedCompiler+        , soptsCompilerCheck = compilerCheck+        , soptsStackYaml = mstack+        , soptsForceReinstall = scoForceReinstall+        , soptsSanityCheck = True+        , soptsSkipGhcCheck = False+        , soptsSkipMsys = configSkipMsys+        , soptsUpgradeCabal = scoUpgradeCabal+        , soptsResolveMissingGHC = Nothing+        , soptsStackSetupYaml = scoStackSetupYaml+        , soptsGHCBindistURL = scoGHCBindistURL+        }+    let compiler = case wantedCompiler of+            GhcVersion _ -> "GHC"+            GhcjsVersion {} -> "GHCJS"+    case mpaths of+        Nothing -> $logInfo $ "stack will use the " <> compiler <> " on your PATH"+        Just _ -> $logInfo $ "stack will use a sandboxed " <> compiler <> " it installed"+    $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"
src/Stack/Sig/GPG.hs view
@@ -27,7 +27,7 @@ import           Data.Monoid ((<>)) import qualified Data.Text as T import           Path-import           Stack.Types+import           Stack.Types.Sig import           System.Directory (findExecutable) import           System.Environment (lookupEnv) import           System.Exit (ExitCode(..))
src/Stack/Sig/Sign.hs view
@@ -38,7 +38,8 @@ import           Path.IO import           Stack.Package import           Stack.Sig.GPG-import           Stack.Types+import           Stack.Types.PackageIdentifier+import           Stack.Types.Sig import qualified System.FilePath as FP  -- | Sign a haskell package with the given url of the signature@@ -116,7 +117,7 @@             url <> "/upload/signature/" <> show name <> "/" <> show version <>             "/" <>             show fingerprint-    req <- parseUrl fullUrl+    req <- parseUrlThrow fullUrl     let put =             req             { method = methodPut
src/Stack/Solver.hs view
@@ -33,8 +33,10 @@ 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)@@ -51,7 +53,7 @@ import qualified Data.Text.Lazy              as LT import           Data.Text.Lazy.Encoding     (decodeUtf8With) import           Data.Tuple                  (swap)-import qualified Data.Yaml                   as Yaml+import qualified Data.Yaml.Extra             as Yaml import qualified Distribution.Package        as C import qualified Distribution.PackageDescription as C import qualified Distribution.Text           as C@@ -61,13 +63,20 @@ import           Path.Find                   (findFiles) import           Path.IO                     hiding (findExecutable, findFiles) import           Stack.BuildPlan-import           Stack.Constants             (stackDotYaml)+import           Stack.Constants             (stackDotYaml, wiredInPackages) import           Stack.Package               (printCabalFileWarning                                              , hpack                                              , readPackageUnresolved) import           Stack.Setup import           Stack.Setup.Installed-import           Stack.Types+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.Build+import           Stack.Types.Compiler import           Stack.Types.Internal        ( HasTerminal                                              , HasReExec                                              , HasLogLevel)@@ -75,6 +84,7 @@ import qualified System.FilePath             as FP import           System.Process.Read +import qualified Data.Text.Normalize         as T ( normalize , NormalizationMode(NFC) )  data ConstraintType = Constraint | Preference deriving (Eq) type ConstraintSpec = Map PackageName (Version, Map FlagName Bool)@@ -126,6 +136,7 @@    where     errCheck = T.isInfixOf "Could not resolve dependencies"+    linesNoCR = map stripCR . T.lines     cabalBuildErrMsg e =                ">>>> Cabal errors begin\n"             <> e@@ -157,7 +168,7 @@         else errExit msg      parseConflictingPkgs msg =-        let ls = dropWhile (not . errCheck) $ T.lines msg+        let ls = dropWhile (not . errCheck) $ linesNoCR msg             select s = ((T.isPrefixOf "trying:" s)                       || (T.isPrefixOf "next goal:" s))                       && (T.isSuffixOf "(user goal)" s)@@ -170,8 +181,7 @@     parseCabalOutput bs = do         let ls = drop 1                $ dropWhile (not . T.isPrefixOf "In order, ")-               $ map stripCR-               $ T.lines+               $ linesNoCR                $ decodeUtf8 bs             (errs, pairs) = partitionEithers $ map parseCabalOutputLine ls         if null errs@@ -256,6 +266,7 @@         assert (not . null . versionString $ version) $             T.concat               [ (if constraintType == Constraint+                    || name `HashSet.member` wiredInPackages                  then "constraint: "                  else "preference: ")               , T.pack $ packageNameString name@@ -279,7 +290,7 @@           , "compiler available on your PATH." ]      config <- asks getConfig-    mpaths <- ensureCompiler SetupOpts+    mpaths <- fst <$> ensureCompiler SetupOpts         { soptsInstallIfMissing  = configInstallGHC config         , soptsUseSystem         = configSystemGHC config         , soptsWantedCompiler    = compiler@@ -559,8 +570,9 @@     -- 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         getNameMismatchPkg (fp, gpd)-            | (show . gpdPackageName) gpd /= (FP.takeBaseName . toFilePath) fp+            | (normalizeString . show . gpdPackageName) gpd /= (normalizeString . FP.takeBaseName . toFilePath) fp                 = Just fp             | otherwise = Nothing         nameMismatchPkgs = mapMaybe getNameMismatchPkg packages@@ -679,6 +691,8 @@         Nothing -> throwM (SolverGiveUp giveUpMsg)         Just x -> return x +    mOldResolver <- asks (fmap (projectResolver . fst) . configMaybeProject . getConfig)+     let         flags = removeSrcPkgDefaultFlags gpds (fmap snd (Map.union srcs edeps))         versions = fmap fst edeps@@ -695,14 +709,14 @@          changed =    any (not . Map.null) [newVersions, goneVersions]                   || any (not . Map.null) [newFlags, goneFlags]+                  || any (/= resolver') mOldResolver      if changed then do         $logInfo ""         $logInfo $ "The following changes will be made to "                    <> T.pack relStackYaml <> ":" -        -- TODO print whether resolver changed from previous-        $logInfo $ "* Resolver is " <> resolverName resolver+        printResolver mOldResolver resolver'          printFlags newFlags  "* Flags to be added"         printDeps  newVersions   "* Dependencies to be added"@@ -722,6 +736,16 @@      where         indent t = T.unlines $ fmap ("    " <>) (T.lines t)++        printResolver mOldRes res = do+            forM_ mOldRes $ \oldRes ->+                when (res /= oldRes) $ do+                    $logInfo $ T.concat+                        [ "* Resolver changes from "+                        , resolverName oldRes+                        , " to "+                        , resolverName res+                        ]          printFlags fl msg = do             when ((not . Map.null) fl) $ do
− src/Stack/Types.hs 
@@ -1,22 +0,0 @@--- | All types.--module Stack.Types-  (module X)-  where--import Stack.Types.BuildPlan as X-import Stack.Types.FlagName as X-import Stack.Types.GhcPkgId as X-import Stack.Types.PackageIdentifier as X-import Stack.Types.PackageIndex as X-import Stack.Types.PackageName as X-import Stack.Types.Version as X-import Stack.Types.Config as X-import Stack.Types.Docker as X-import Stack.Types.Nix as X-import Stack.Types.Image as X-import Stack.Types.Build as X-import Stack.Types.Urls as X-import Stack.Types.Package as X-import Stack.Types.Compiler as X-import Stack.Types.Sig as X
src/Stack/Types/Build.hs view
@@ -31,43 +31,47 @@     ,defaultBuildOpts     ,TaskType(..)     ,TaskConfigOpts(..)+    ,BuildCache(..)+    ,buildCacheVC     ,ConfigCache(..)-    ,ConstructPlanException(..)+    ,configCacheVC     ,configureOpts     ,isStackOpt-    ,BadDependency(..)     ,wantedLocalPackages     ,FileCacheInfo (..)     ,ConfigureOpts (..)-    ,PrecompiledCache (..))+    ,PrecompiledCache (..)+    ,precompiledCacheVC)     where  import           Control.DeepSeq import           Control.Exception--import           Data.Binary (getWord8, putWord8, gput, gget)-import           Data.Binary.VersionTagged+import           Data.Binary (Binary)+import           Data.Binary.Tagged (HasSemanticVersion, HasStructuralInfo) import qualified Data.ByteString as S import           Data.Char (isSpace) import           Data.Data import           Data.Hashable-import           Data.List (dropWhileEnd, nub, intercalate)+import           Data.List (dropWhileEnd, intercalate) 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) import           Data.Time.Calendar import           Data.Time.Clock-import           Distribution.System (Arch) import           Distribution.PackageDescription (TestSuiteInterface)-import           Distribution.Text (display)-import           GHC.Generics (Generic, from, to)+import           Distribution.System (Arch)+import qualified Distribution.Text as C+import           GHC.Generics (Generic) import           Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, (</>)) import           Path.Extra (toFilePathNoTrailingSep) import           Prelude@@ -92,6 +96,7 @@         (Maybe (CompilerVersion, Arch))         (CompilerVersion, Arch)         GHCVariant+        CompilerBuild         VersionCheck         (Maybe (Path Abs File))         Text -- recommended resolution@@ -103,9 +108,7 @@     (Path Abs File) -- stack.yaml   | TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString   | TestSuiteTypeUnsupported TestSuiteInterface-  | ConstructPlanExceptions-        [ConstructPlanException]-        (Path Abs File) -- stack.yaml+  | ConstructPlanFailed String   | CabalExitedUnsuccessfully         ExitCode         PackageIdentifier@@ -143,14 +146,14 @@                ", the package id couldn't be found " <> "(via ghc-pkg describe " <>                packageNameString name <> "). This shouldn't happen, " <>                "please report as a bug")-    show (CompilerVersionMismatch mactual (expected, earch) ghcVariant check mstack resolution) = concat+    show (CompilerVersionMismatch mactual (expected, earch) ghcVariant ghcBuild check mstack resolution) = concat                 [ case mactual of                     Nothing -> "No compiler found, expected "                     Just (actual, arch) -> concat                         [ "Compiler version mismatched, found "                         , compilerVersionString actual                         , " ("-                        , display arch+                        , C.display arch                         , ")"                         , ", but expected "                         ]@@ -160,8 +163,9 @@                     NewerMinor -> "minor version match or newer with "                 , compilerVersionString expected                 , " ("-                , display earch+                , C.display earch                 , ghcVariantSuffix ghcVariant+                , compilerBuildSuffix ghcBuild                 , ") (based on "                 , case mstack of                     Nothing -> "command line arguments"@@ -216,34 +220,6 @@           doubleIndent = indent . indent     show (TestSuiteTypeUnsupported interface) =               ("Unsupported test suite type: " <> show interface)-    show (ConstructPlanExceptions exceptions stackYaml) =-        "While constructing the BuildPlan the following exceptions were encountered:" ++-        appendExceptions exceptions' ++-        if Map.null extras then "" else (unlines-                $ ("\n\nRecommended action: try adding the following to your extra-deps in "-                    ++ toFilePath stackYaml)-                : map (\(name, version) -> concat-                    [ "- "-                    , packageNameString name-                    , "-"-                    , versionString version-                    ]) (Map.toList extras)-                    ++ ["", "You may also want to try the 'stack solver' command"]-                )-         where-             exceptions' = removeDuplicates exceptions-             appendExceptions = foldr (\e -> (++) ("\n\n--" ++ show e)) ""-             removeDuplicates = nub-             extras = Map.unions $ map getExtras exceptions'--             getExtras (DependencyCycleDetected _) = Map.empty-             getExtras (UnknownPackage _) = Map.empty-             getExtras (DependencyPlanFailures _ m) =-                Map.unions $ map go $ Map.toList m-              where-                go (name, (_range, Just version, NotInBuildPlan)) =-                    Map.singleton name version-                go _ = Map.empty      -- Supressing duplicate output     show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) =         let fullCmd = unwords@@ -353,6 +329,7 @@             , innerMsg             , "\n"             ]+    show (ConstructPlanFailed msg) = msg  missingExeError :: Bool -> String -> String missingExeError isSimpleBuildType msg =@@ -370,90 +347,26 @@  instance Exception StackBuildException -data ConstructPlanException-    = DependencyCycleDetected [PackageName]-    | DependencyPlanFailures Package (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency))-    | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all-    -- ^ Recommend adding to extra-deps, give a helpful version number?-    deriving (Typeable, Eq)---- | For display purposes only, Nothing if package not found-type LatestApplicableVersion = Maybe Version---- | Reason why a dependency was not used-data BadDependency-    = NotInBuildPlan-    | Couldn'tResolveItsDependencies-    | DependencyMismatch Version-    deriving (Typeable, Eq)--instance Show ConstructPlanException where-  show e =-    let details = case e of-         (DependencyCycleDetected pNames) ->-           "While checking call stack,\n" ++-           "  dependency cycle detected in packages:" ++ indent (appendLines pNames)-         (DependencyPlanFailures pkg (Map.toList -> pDeps)) ->-           "Failure when adding dependencies:" ++ doubleIndent (appendDeps pDeps) ++ "\n" ++-           "  needed for package " ++ packageIdentifierString (packageIdentifier pkg) ++-           appendFlags (packageFlags pkg)-         (UnknownPackage pName) ->-             "While attempting to add dependency,\n" ++-             "  Could not find package " ++ show pName  ++ " in known packages"-    in indent details-     where-      appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""-      indent = dropWhileEnd isSpace . unlines . fmap (\line -> "  " ++ line) . lines-      doubleIndent = indent . indent-      appendFlags flags =-          if Map.null flags-              then ""-              else " with flags:\n" ++-                  (doubleIndent . intercalate "\n" . map showFlag . Map.toList) flags-      showFlag (name, bool) = show name ++ ": " ++ show bool-      appendDeps = foldr (\dep-> (++) ("\n" ++ showDep dep)) ""-      showDep (name, (range, mlatestApplicable, badDep)) = concat-        [ show name-        , ": needed ("-        , display range-        , ")"-        , ", "-        , let latestApplicableStr =-                case mlatestApplicable of-                    Nothing -> ""-                    Just la -> " (latest applicable is " ++ versionString la ++ ")"-           in case badDep of-                NotInBuildPlan -> "stack configuration has no specified version" ++ latestApplicableStr-                Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies"-                DependencyMismatch version ->-                    case mlatestApplicable of-                        Just la-                            | la == version ->-                                versionString version ++-                                " found (latest applicable version available)"-                        _ -> versionString version ++ " found" ++ latestApplicableStr-        ]-         {- TODO Perhaps change the showDep function to look more like this:-          dropQuotes = filter ((/=) '\"')-         (VersionOutsideRange pName pIdentifier versionRange) ->-             "Exception: Stack.Build.VersionOutsideRange\n" ++-             "  While adding dependency for package " ++ show pName ++ ",\n" ++-             "  " ++ dropQuotes (show pIdentifier) ++ " was found to be outside its allowed version range.\n" ++-             "  Allowed version range is " ++ display versionRange ++ ",\n" ++-             "  should you correct the version range for " ++ dropQuotes (show pIdentifier) ++ ", found in [extra-deps] in the project's stack.yaml?"-             -}-- ---------------------------------------------- - -- | Package dependency oracle. newtype PkgDepsOracle =     PkgDeps PackageName-    deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+    deriving (Show,Typeable,Eq,Hashable,Store,NFData) --- | Stored on disk to know whether the flags have changed or any--- files have changed.+-- | Stored on disk to know whether the files have changed.+data BuildCache = BuildCache+    { buildCacheTimes :: !(Map FilePath FileCacheInfo)+      -- ^ Modification times of files.+    }+    deriving (Generic, Eq, Show, Data, Typeable)+instance NFData BuildCache+instance Store BuildCache++buildCacheVC :: VersionConfig BuildCache+buildCacheVC = storeVersionConfig "build-v1" "KVUoviSWWAd7tiRRGeWAvd0UIN4="++-- | Stored on disk to know whether the flags have changed. data ConfigCache = ConfigCache     { configCacheOpts :: !ConfigureOpts       -- ^ All options used for this package.@@ -469,25 +382,13 @@     , configCacheHaddock :: !Bool       -- ^ Are haddocks to be built?     }-    deriving (Generic,Eq,Show)-instance Binary ConfigCache where-    put x = do-        -- magic string-        putWord8 1-        putWord8 3-        putWord8 4-        putWord8 8-        gput $ from x-    get = do-        1 <- getWord8-        3 <- getWord8-        4 <- getWord8-        8 <- getWord8-        fmap to gget+    deriving (Generic, Eq, Show, Data, Typeable)+instance Store ConfigCache instance NFData ConfigCache-instance HasStructuralInfo ConfigCache-instance HasSemanticVersion ConfigCache +configCacheVC :: VersionConfig ConfigCache+configCacheVC = storeVersionConfig "config-v1" "NMEzMXpksE1h7STRzlQ2f6Glkjo="+ -- | A task to perform when building data Task = Task     { taskProvides        :: !PackageIdentifier@@ -584,6 +485,7 @@     , "--enable-benchmarks"     , "--enable-library-profiling"     , "--enable-executable-profiling"+    , "--enable-profiling"     , "--exact-configuration"     ] || elem t     [ "--user"@@ -631,7 +533,9 @@ configureOptsNoDir econfig bco deps isLocal package = concat     [ depOptions     , ["--enable-library-profiling" | boptsLibProfile bopts || boptsExeProfile bopts]-    , ["--enable-executable-profiling" | boptsExeProfile bopts && isLocal]+    -- Cabal < 1.21.1 does not support --enable-profiling, use --enable-executable-profiling instead+    , let profFlag = "--enable-" <> concat ["executable-" | not newerCabal] <> "profiling"+      in [ profFlag | boptsExeProfile bopts && isLocal]     , ["--enable-split-objs" | boptsSplitObjs bopts]     , map (\(name,enabled) ->                        "-f" <>@@ -641,12 +545,11 @@                        flagNameString name)                     (Map.toList flags)     , concatMap (\x -> ["--ghc-options", T.unpack x]) (packageGhcOptions package)-    , map (("--extra-include-dirs=" ++) . T.unpack) (Set.toList (configExtraIncludeDirs config))-    , map (("--extra-lib-dirs=" ++) . T.unpack) (Set.toList (configExtraLibDirs config))-    , if whichCompiler (envConfigCompilerVersion econfig) == Ghcjs-        then ["--ghcjs"]-        else []-    , if useExactConf then ["--exact-configuration"] else []+    , map (("--extra-include-dirs=" ++) . toFilePathNoTrailingSep) (Set.toList (configExtraIncludeDirs config))+    , map (("--extra-lib-dirs=" ++) . toFilePathNoTrailingSep) (Set.toList (configExtraLibDirs config))+    , maybe [] (\customGcc -> ["--with-gcc=" ++ toFilePath customGcc]) (configOverrideGccPath config)+    , ["--ghcjs" | whichCompiler (envConfigCompilerVersion econfig) == Ghcjs]+    , ["--exact-configuration" | useExactConf]     ]   where     config = getConfig econfig@@ -705,9 +608,8 @@     -- if we can use an existing precompiled cache.     , coNoDirs :: ![String]     }-    deriving (Show, Eq, Generic)-instance Binary ConfigureOpts-instance HasStructuralInfo ConfigureOpts+    deriving (Show, Eq, Generic, Data, Typeable)+instance Store ConfigureOpts instance NFData ConfigureOpts  -- | Information on a compiled package: the library conf file (if relevant),@@ -719,8 +621,12 @@     , pcExes    :: ![FilePath]     -- ^ Full paths to executables     }-    deriving (Show, Eq, Generic)+    deriving (Show, Eq, Generic, Data, Typeable) instance Binary PrecompiledCache instance HasSemanticVersion PrecompiledCache instance HasStructuralInfo PrecompiledCache+instance Store PrecompiledCache instance NFData PrecompiledCache++precompiledCacheVC :: VersionConfig PrecompiledCache+precompiledCacheVC = storeVersionConfig "precompiled-v1" "eMzSOwaHJMamA5iNKs1A025frlQ="
src/Stack/Types/BuildPlan.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE DataKinds                  #-} -- | Shared types for various stackage packages. module Stack.Types.BuildPlan     ( -- * Types@@ -20,6 +22,7 @@     , Component (..)     , SnapName (..)     , MiniBuildPlan (..)+    , miniBuildPlanVC     , MiniPackageInfo (..)     , CabalFileInfo (..)     , GitSHA1 (..)@@ -30,36 +33,37 @@     ) where  import           Control.Applicative-import           Control.Arrow                   ((&&&))-import           Control.Exception               (Exception)-import           Control.Monad.Catch             (MonadThrow, throwM)-import           Data.Aeson                      (FromJSON (..), ToJSON (..),-                                                  object, withObject, withText,-                                                  (.!=), (.:), (.:?), (.=))-import           Data.Binary.VersionTagged-import           Data.ByteString                 (ByteString)-import qualified Data.ByteString                 as BS-import           Data.Hashable                   (Hashable)-import qualified Data.HashMap.Strict             as HashMap-import           Data.IntMap                     (IntMap)-import qualified Data.IntMap                     as IntMap-import           Data.Map                        (Map)-import qualified Data.Map                        as Map-import           Data.Maybe                      (fromMaybe)+import           Control.Arrow ((&&&))+import           Control.DeepSeq (NFData)+import           Control.Exception (Exception)+import           Control.Monad.Catch (MonadThrow, throwM)+import           Data.Aeson (FromJSON (..), ToJSON (..), 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 qualified Data.Map as Map+import           Data.Maybe (fromMaybe) import           Data.Monoid-import           Data.Set                        (Set)-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.Typeable                   (TypeRep, Typeable, typeOf)-import           Data.Vector                     (Vector)-import           Distribution.System             (Arch, OS (..))-import qualified Distribution.Text               as DT-import qualified Distribution.Version            as C-import           GHC.Generics                    (Generic)+import           Data.Set (Set)+import           Data.Store (Store)+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 qualified Distribution.Version as C+import           GHC.Generics (Generic) import           Prelude -- Fix AMP warning import           Safe (readMay) import           Stack.Types.Compiler@@ -277,8 +281,7 @@  -- | Name of an executable. newtype ExeName = ExeName { unExeName :: Text }-    deriving (Show, Eq, Ord, Hashable, IsString, Generic, Binary, NFData)-instance HasStructuralInfo ExeName+    deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData, Data, Typeable) instance ToJSON ExeName where     toJSON = toJSON . unExeName instance FromJSON ExeName where@@ -428,12 +431,13 @@     { mbpCompilerVersion :: !CompilerVersion     , mbpPackages :: !(Map PackageName MiniPackageInfo)     }-    deriving (Generic, Show, Eq)-instance Binary MiniBuildPlan+    deriving (Generic, Show, Eq, Data, Typeable)+instance Store MiniBuildPlan instance NFData MiniBuildPlan-instance HasStructuralInfo MiniBuildPlan-instance HasSemanticVersion MiniBuildPlan +miniBuildPlanVC :: VersionConfig MiniBuildPlan+miniBuildPlanVC = storeVersionConfig "mbp-v1" "C8q73RrYq3plf9hDCapjWpnm_yc="+ -- | Information on a single package for the 'MiniBuildPlan'. data MiniPackageInfo = MiniPackageInfo     { mpiVersion :: !Version@@ -454,13 +458,12 @@     -- the cabal file contents. Useful for grabbing the correct cabal file     -- revision directly from a Git repo     }-    deriving (Generic, Show, Eq)-instance Binary MiniPackageInfo-instance HasStructuralInfo MiniPackageInfo+    deriving (Generic, Show, Eq, Data, Typeable)+instance Store MiniPackageInfo instance NFData MiniPackageInfo  newtype GitSHA1 = GitSHA1 ByteString-    deriving (Generic, Show, Eq, NFData, HasStructuralInfo, Binary)+    deriving (Generic, Show, Eq, NFData, Store, Data, Typeable)  newtype SnapshotHash = SnapshotHash { unShapshotHash :: ByteString }     deriving (Generic, Show, Eq)
src/Stack/Types/Compiler.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} @@ -6,10 +7,11 @@  import           Control.DeepSeq import           Data.Aeson-import           Data.Binary.VersionTagged (Binary, HasStructuralInfo)+import           Data.Data import           Data.Map (Map) import qualified Data.Map as Map import           Data.Monoid ((<>))+import           Data.Store (Store) import qualified Data.Text as T import           GHC.Generics (Generic) import           Stack.Types.Version@@ -33,9 +35,8 @@     | GhcjsVersion         {-# UNPACK #-} !Version -- GHCJS version         {-# UNPACK #-} !Version -- GHC version-    deriving (Generic, Show, Eq, Ord)-instance Binary CompilerVersion-instance HasStructuralInfo CompilerVersion+    deriving (Generic, Show, Eq, Ord, Data, Typeable)+instance Store CompilerVersion instance NFData CompilerVersion instance ToJSON CompilerVersion where     toJSON = toJSON . compilerVersionText
src/Stack/Types/Config.hs view
@@ -44,6 +44,10 @@   ,parseGHCVariant   ,HasGHCVariant(..)   ,snapshotsDir+  -- ** CompilerBuild+  ,CompilerBuild(..)+  ,compilerBuildName+  ,compilerBuildSuffix   -- ** EnvConfig & HasEnvConfig   ,EnvConfig(..)   ,HasEnvConfig(..)@@ -73,16 +77,19 @@   ,PackageLocation(..)   ,RemotePackageType(..)   -- ** PackageIndex, IndexName & IndexLocation++  -- Re-exports   ,PackageIndex(..)   ,IndexName(..)+  ,indexNameText+  ,IndexLocation(..)+  -- Config fields   ,configPackageIndex   ,configPackageIndexCache   ,configPackageIndexGz   ,configPackageIndexRoot   ,configPackageIndexRepo   ,configPackageTarball-  ,indexNameText-  ,IndexLocation(..)   -- ** Project & ProjectAndConfigMonoid   ,Project(..)   ,ProjectAndConfigMonoid(..)@@ -119,6 +126,8 @@   ,hpcReportDir   ,installationRootDeps   ,installationRootLocal+  ,hoogleRoot+  ,hoogleDatabasePath   ,packageDatabaseDeps   ,packageDatabaseExtra   ,packageDatabaseLocal@@ -147,7 +156,7 @@ import           Control.Applicative import           Control.Arrow ((&&&)) import           Control.Exception-import           Control.Monad (liftM, mzero, forM, join)+import           Control.Monad (liftM, mzero, join) import           Control.Monad.Catch (MonadThrow, throwM) import           Control.Monad.Logger (LogLevel(..)) import           Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)@@ -157,7 +166,6 @@                   withObjectWarnings, WarningParser, Object, jsonSubWarnings,                   jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings) import           Data.Attoparsec.Args-import           Data.Binary (Binary) import           Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import           Data.Either (partitionEithers)@@ -165,7 +173,6 @@ import           Data.List (stripPrefix) import           Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty-import           Data.Hashable (Hashable) import           Data.Map (Map) import qualified Data.Map as Map import qualified Data.Map.Strict as M@@ -178,12 +185,13 @@ import           Data.Text.Encoding (encodeUtf8, decodeUtf8) import           Data.Typeable import           Data.Yaml (ParseException)+import qualified Data.Yaml as Yaml import           Distribution.System (Platform) import qualified Distribution.Text import           Distribution.Version (anyVersion) import           GHC.Generics (Generic) import           Generics.Deriving.Monoid (memptydefault, mappenddefault)-import           Network.HTTP.Client (parseUrl)+import           Network.HTTP.Client (parseRequest) import           Path import qualified Paths_stack as Meta import           Stack.Types.BuildPlan (MiniBuildPlan(..), SnapName, renderSnapName, parseSnapName, SnapshotHash (..), trimmedSnapshotHash)@@ -273,7 +281,7 @@          ,configSkipGHCCheck        :: !Bool          -- ^ Don't bother checking the GHC version or architecture.          ,configSkipMsys            :: !Bool-         -- ^ On Windows: don't use a locally installed MSYS+         -- ^ On Windows: don't use a sandboxed MSYS          ,configCompilerCheck       :: !VersionCheck          -- ^ Specifies which versions of the compiler are acceptable.          ,configLocalBin            :: !(Path Abs Dir)@@ -282,9 +290,11 @@          -- ^ Require a version of stack within this range.          ,configJobs                :: !Int          -- ^ How many concurrent jobs to run, defaults to number of capabilities-         ,configExtraIncludeDirs    :: !(Set Text)+         ,configOverrideGccPath     :: !(Maybe (Path Abs File))+         -- ^ Optional gcc override path+         ,configExtraIncludeDirs    :: !(Set (Path Abs Dir))          -- ^ --extra-include-dirs arguments-         ,configExtraLibDirs        :: !(Set Text)+         ,configExtraLibDirs        :: !(Set (Path Abs Dir))          -- ^ --extra-lib-dirs arguments          ,configConcurrentTests     :: !Bool          -- ^ Run test suites concurrently@@ -322,7 +332,7 @@          ,configMaybeProject        :: !(Maybe (Project, Path Abs File))          } --- | Which packages to ghc-options on the command line apply to?+-- | Which packages do ghc-options on the command line apply to? data ApplyGhcOptions = AGOTargets -- ^ all local targets                      | AGOLocals -- ^ all local packages, even non-targets                      | AGOEverything -- ^ every package@@ -336,61 +346,6 @@             "everything" -> return AGOEverything             _ -> fail $ "Invalid ApplyGhcOptions: " ++ show t --- | Information on a single package index-data PackageIndex = PackageIndex-    { indexName :: !IndexName-    , indexLocation :: !IndexLocation-    , indexDownloadPrefix :: !Text-    -- ^ URL prefix for downloading packages-    , indexGpgVerify :: !Bool-    -- ^ GPG-verify the package index during download. Only applies to Git-    -- repositories for now.-    , indexRequireHashes :: !Bool-    -- ^ Require that hashes and package size information be available for packages in this index-    }-    deriving Show-instance FromJSON (WithJSONWarnings PackageIndex) where-    parseJSON = withObjectWarnings "PackageIndex" $ \o -> do-        name <- o ..: "name"-        prefix <- o ..: "download-prefix"-        mgit <- o ..:? "git"-        mhttp <- o ..:? "http"-        loc <--            case (mgit, mhttp) of-                (Nothing, Nothing) -> fail $-                    "Must provide either Git or HTTP URL for " ++-                    T.unpack (indexNameText name)-                (Just git, Nothing) -> return $ ILGit git-                (Nothing, Just http) -> return $ ILHttp http-                (Just git, Just http) -> return $ ILGitHttp git http-        gpgVerify <- o ..:? "gpg-verify" ..!= False-        reqHashes <- o ..:? "require-hashes" ..!= False-        return PackageIndex-            { indexName = name-            , indexLocation = loc-            , indexDownloadPrefix = prefix-            , indexGpgVerify = gpgVerify-            , indexRequireHashes = reqHashes-            }---- | Unique name for a package index-newtype IndexName = IndexName { unIndexName :: ByteString }-    deriving (Show, Eq, Ord, Hashable, Binary)-indexNameText :: IndexName -> Text-indexNameText = decodeUtf8 . unIndexName-instance ToJSON IndexName where-    toJSON = toJSON . indexNameText-instance FromJSON IndexName where-    parseJSON = withText "IndexName" $ \t ->-        case parseRelDir (T.unpack t) of-            Left e -> fail $ "Invalid index name: " ++ show e-            Right _ -> return $ IndexName $ encodeUtf8 t---- | Location of the package index. This ensures that at least one of Git or--- HTTP is available.-data IndexLocation = ILGit !Text | ILHttp !Text | ILGitHttp !Text !Text-    deriving (Show, Eq, Ord)- -- | Controls which version of the environment is used data EnvSettings = EnvSettings     { esIncludeLocals :: !Bool@@ -523,7 +478,14 @@ data EnvConfig = EnvConfig     {envConfigBuildConfig :: !BuildConfig     ,envConfigCabalVersion :: !Version+    -- ^ This is the version of Cabal that stack will use to compile Setup.hs files+    -- in the build process.+    --+    -- Note that this is not necessarily the same version as the one that stack+    -- depends on as a library and which is displayed when running+    -- @stack list-dependencies | grep Cabal@ in the stack project.     ,envConfigCompilerVersion :: !CompilerVersion+    ,envConfigCompilerBuild :: !CompilerBuild     ,envConfigPackages   :: !(Map (Path Abs Dir) TreatLikeExtraDep)} instance HasBuildConfig EnvConfig where     getBuildConfig = envConfigBuildConfig@@ -575,11 +537,11 @@     parseJSON (String t) = do         WithJSONWarnings loc _ <- parseJSON $ String t         return $ noJSONWarnings-               (PackageEntry+            PackageEntry                 { peExtraDep = False                 , peLocation = loc                 , peSubdirs = []-                })+                }     parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry         <$> o ..:? "extra-dep" ..!= False         <*> jsonSubWarnings (o ..: "location")@@ -602,8 +564,8 @@ instance ToJSON PackageLocation where     toJSON (PLFilePath fp) = toJSON fp     toJSON (PLRemote t RPTHttp) = toJSON t-    toJSON (PLRemote x (RPTGit y)) = toJSON $ T.unwords ["git", x, y]-    toJSON (PLRemote x (RPTHg  y)) = toJSON $ T.unwords ["hg",  x, y]+    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@@ -613,7 +575,7 @@       where         file t = pure $ PLFilePath $ T.unpack t         http t =-            case parseUrl $ T.unpack t of+            case parseRequest $ T.unpack t of                 Left  _ -> mzero                 Right _ -> return $ PLRemote t RPTHttp @@ -647,14 +609,14 @@  instance ToJSON Project where     toJSON p = object $-        (maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p))-        ((maybe id (\msg -> (("user-message" .= msg) :)) (projectUserMsg p))+        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-        ])+        ]  data IsLoaded = Loaded | NotLoaded @@ -684,6 +646,7 @@     -- 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)  instance ToJSON (ResolverThat's k) where@@ -705,7 +668,7 @@      parseJSON (String t) = either (fail . show) return (noJSONWarnings <$> parseResolverText t) -    parseJSON _ = fail $ "Invalid Resolver, must be Object or String"+    parseJSON _ = fail "Invalid Resolver, must be Object or String"  -- | Convert a Resolver into its @Text@ representation, as will be used by -- directory names@@ -798,7 +761,7 @@   ConfigMonoid     { configMonoidStackRoot          :: !(First (Path Abs Dir))     -- ^ See: 'configStackRoot'-    , configMonoidWorkDir            :: !(First FilePath)+    , configMonoidWorkDir            :: !(First (Path Rel Dir))     -- ^ See: 'configWorkDir'.     , configMonoidBuildOpts          :: !BuildOptsMonoid     -- ^ build options.@@ -828,18 +791,18 @@     -- ^ See: 'configCompilerCheck'     ,configMonoidRequireStackVersion :: !IntersectingVersionRange     -- ^ See: 'configRequireStackVersion'-    ,configMonoidOS                  :: !(First String)-    -- ^ Used for overriding the platform     ,configMonoidArch                :: !(First String)     -- ^ Used for overriding the platform     ,configMonoidGHCVariant          :: !(First GHCVariant)     -- ^ Used for overriding the GHC variant     ,configMonoidJobs                :: !(First Int)     -- ^ See: 'configJobs'-    ,configMonoidExtraIncludeDirs    :: !(Set Text)+    ,configMonoidExtraIncludeDirs    :: !(Set (Path Abs Dir))     -- ^ See: 'configExtraIncludeDirs'-    ,configMonoidExtraLibDirs        :: !(Set Text)+    ,configMonoidExtraLibDirs        :: !(Set (Path Abs Dir))     -- ^ See: 'configExtraLibDirs'+    , configMonoidOverrideGccPath    :: !(First (Path Abs File))+    -- ^ Allow users to override the path to gcc     ,configMonoidConcurrentTests     :: !(First Bool)     -- ^ See: 'configConcurrentTests'     ,configMonoidLocalBinPath        :: !(First FilePath)@@ -907,12 +870,12 @@     configMonoidRequireStackVersion <- IntersectingVersionRange <$> unVersionRangeJSON <$>                                        obj ..:? configMonoidRequireStackVersionName                                            ..!= VersionRangeJSON anyVersion-    configMonoidOS <- First <$> obj ..:? configMonoidOSName     configMonoidArch <- First <$> obj ..:? configMonoidArchName     configMonoidGHCVariant <- First <$> obj ..:? configMonoidGHCVariantName     configMonoidJobs <- First <$> obj ..:? configMonoidJobsName     configMonoidExtraIncludeDirs <- obj ..:?  configMonoidExtraIncludeDirsName ..!= Set.empty     configMonoidExtraLibDirs <- obj ..:?  configMonoidExtraLibDirsName ..!= Set.empty+    configMonoidOverrideGccPath <- First <$> obj ..:? configMonoidOverrideGccPathName     configMonoidConcurrentTests <- First <$> obj ..:? configMonoidConcurrentTestsName     configMonoidLocalBinPath <- First <$> obj ..:? configMonoidLocalBinPathName     configMonoidImageOpts <- jsonSubWarnings (obj ..:?  configMonoidImageOptsName ..!= mempty)@@ -927,11 +890,7 @@     configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName      configMonoidGhcOptions <- obj ..:? configMonoidGhcOptionsName ..!= mempty--    extraPath <- obj ..:? configMonoidExtraPathName ..!= []-    configMonoidExtraPath <- forM extraPath $-        either (fail . show) return . parseAbsDir . T.unpack-+    configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= []     configMonoidSetupInfoLocations <-         maybeToList <$> jsonSubWarningsT (obj ..:?  configMonoidSetupInfoLocationsName)     configMonoidPvpBounds <- First <$> obj ..:? configMonoidPvpBoundsName@@ -999,9 +958,6 @@ configMonoidRequireStackVersionName :: Text configMonoidRequireStackVersionName = "require-stack-version" -configMonoidOSName :: Text-configMonoidOSName = "os"- configMonoidArchName :: Text configMonoidArchName = "arch" @@ -1017,6 +973,9 @@ configMonoidExtraLibDirsName :: Text configMonoidExtraLibDirsName = "extra-lib-dirs" +configMonoidOverrideGccPathName :: Text+configMonoidOverrideGccPathName = "with-gcc"+ configMonoidConcurrentTestsName :: Text configMonoidConcurrentTestsName = "concurrent-tests" @@ -1090,14 +1049,14 @@         [ "Could not parse '"         , toFilePath configFile         , "':\n"-        , show exception+        , Yaml.prettyPrintParseException exception         , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/."         ]     show (ParseCustomSnapshotException url exception) = concat         [ "Could not parse '"         , T.unpack url         , "':\n"-        , show exception+        , Yaml.prettyPrintParseException exception         -- FIXME: Link to docs about custom snapshots         -- , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/."         ]@@ -1133,7 +1092,7 @@         ,"version range specified in stack.yaml ("         , T.unpack (versionRangeText requiredRange)         , ")." ]-    show (NoMatchingSnapshot whichCmd names) = concat $+    show (NoMatchingSnapshot whichCmd names) = concat         [ "None of the following snapshots provides a compiler matching "         , "your package(s):\n"         , unlines $ map (\name -> "    - " <> T.unpack (renderSnapName name))@@ -1155,14 +1114,10 @@         , unlines $ fmap ("    " <>) (lines errDesc)         , showOptions whichCmd         ]-    show (NoSuchDirectory dir) = concat-        ["No directory could be located matching the supplied path: "-        ,dir-        ]-    show (ParseGHCVariantException v) = concat-        [ "Invalid ghc-variant value: "-        , v-        ]+    show (NoSuchDirectory dir) =+        "No directory could be located matching the supplied path: " ++ dir+    show (ParseGHCVariantException v) =+        "Invalid ghc-variant value: " ++ v     show (BadStackRoot stackRoot) = concat         [ "Invalid stack root: '"         , toFilePath stackRoot@@ -1186,7 +1141,7 @@ instance Exception ConfigException  showOptions :: WhichSolverCmd -> String-showOptions whichCmd = unlines $ ["\nThis may be resolved by:"] ++ options+showOptions whichCmd = unlines $ "\nThis may be resolved by:" : options   where     options =         case whichCmd of@@ -1283,7 +1238,7 @@     parseRelDir (Distribution.Text.display platform ++ platformVariantSuffix platformVariant)  -- | Directory containing snapshots-snapshotsDir :: (MonadReader env m, HasConfig env, HasGHCVariant env, MonadThrow m) => m (Path Abs Dir)+snapshotsDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Abs Dir) snapshotsDir = do     config <- asks getConfig     platform <- platformGhcRelDir@@ -1304,6 +1259,19 @@     psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel     return $ getProjectWorkDir bc </> $(mkRelDir "install") </> psc +-- | Hoogle directory.+hoogleRoot :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)+hoogleRoot = do+    bc <- asks getBuildConfig+    psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel+    return $ getProjectWorkDir bc </> $(mkRelDir "hoogle") </> psc++-- | Get the hoogle database path.+hoogleDatabasePath :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs File)+hoogleDatabasePath = do+    dir <- hoogleRoot+    return (dir </> $(mkRelFile "database.hoo"))+ -- | Path for platform followed by snapshot name followed by compiler -- name. platformSnapAndCompilerRel@@ -1316,17 +1284,35 @@     ghc <- compilerVersionDir     useShaPathOnWindows (platform </> name </> ghc) --- | Relative directory for the platform identifier+-- | Relative directory for the platform and GHC identifier platformGhcRelDir-    :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)+    :: (MonadReader env m, HasEnvConfig env, MonadThrow m)     => m (Path Rel Dir) platformGhcRelDir = do+    envConfig <- asks getEnvConfig+    verOnly <- platformGhcVerOnlyRelDirStr+    parseRelDir (mconcat [ verOnly+                         , compilerBuildSuffix (envConfigCompilerBuild envConfig)])++-- | Relative directory for the platform and GHC identifier without GHC bindist build+platformGhcVerOnlyRelDir+    :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)+    => m (Path Rel Dir)+platformGhcVerOnlyRelDir =+    parseRelDir =<< platformGhcVerOnlyRelDirStr++-- | Relative directory for the platform and GHC identifier without GHC bindist build+-- (before parsing into a Path)+platformGhcVerOnlyRelDirStr+    :: (MonadReader env m, HasPlatform env, HasGHCVariant env)+    => m FilePath+platformGhcVerOnlyRelDirStr = do     platform <- asks getPlatform     platformVariant <- asks getPlatformVariant     ghcVariant <- asks getGHCVariant-    parseRelDir (mconcat [ Distribution.Text.display platform-                         , platformVariantSuffix platformVariant-                         , ghcVariantSuffix ghcVariant ])+    return $ mconcat [ Distribution.Text.display platform+                     , platformVariantSuffix platformVariant+                     , ghcVariantSuffix ghcVariant ]  -- | This is an attempt to shorten stack paths on Windows to decrease our -- chances of hitting 260 symbol path limit. The idea is to calculate@@ -1377,7 +1363,7 @@                          -> m (Path Abs File) configMiniBuildPlanCache name = do     root <- asks getStackRoot-    platform <- platformGhcRelDir+    platform <- platformGhcVerOnlyRelDir     file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache"     -- Yes, cached plans differ based on platform     return (root </> $(mkRelDir "build-plan-cache") </> platform </> file)@@ -1521,8 +1507,6 @@ -- | Specialized bariant of GHC (e.g. libgmp4 or integer-simple) data GHCVariant     = GHCStandard -- ^ Standard bindist-    | GHCGMP4 -- ^ Bindist that supports libgmp4 (centos66)-    | GHCArch -- ^ Bindist built on Arch Linux (bleeding-edge)     | GHCIntegerSimple -- ^ Bindist that uses integer-simple     | GHCCustom String -- ^ Other bindists     deriving (Show)@@ -1537,8 +1521,6 @@ -- | Render a GHC variant to a String. ghcVariantName :: GHCVariant -> String ghcVariantName GHCStandard = "standard"-ghcVariantName GHCGMP4 = "gmp4"-ghcVariantName GHCArch = "arch" ghcVariantName GHCIntegerSimple = "integersimple" ghcVariantName (GHCCustom name) = "custom-" ++ name @@ -1555,14 +1537,28 @@         Nothing           | s == "" -> return GHCStandard           | s == "standard" -> return GHCStandard-          | s == "gmp4" -> return GHCGMP4-          | s == "arch" -> return GHCArch           | s == "integersimple" -> return GHCIntegerSimple           | otherwise -> return (GHCCustom s) +-- | Build of the compiler distribution (e.g. standard, gmp4, tinfo6)+data CompilerBuild+  = CompilerBuildStandard+  | CompilerBuildSpecialized String++-- | Descriptive name for compiler build+compilerBuildName :: CompilerBuild -> String+compilerBuildName CompilerBuildStandard = "standard"+compilerBuildName (CompilerBuildSpecialized s) = s++-- | Suffix to use for filenames/directories constructed with compiler build+compilerBuildSuffix :: CompilerBuild -> String+compilerBuildSuffix CompilerBuildStandard = ""+compilerBuildSuffix (CompilerBuildSpecialized s) = '-' : s+ -- | Information for a file to download. data DownloadInfo = DownloadInfo     { downloadInfoUrl :: Text+      -- ^ URL or absolute file path     , downloadInfoContentLength :: Maybe Int     , downloadInfoSha1 :: Maybe ByteString     } deriving (Show)
src/Stack/Types/Config/Build.hs view
@@ -296,27 +296,27 @@  -- | Haddock Options data HaddockOpts =-  HaddockOpts { toHaddockArgs :: ![String] -- ^ Arguments passed to haddock program+  HaddockOpts { hoAdditionalArgs :: ![String] -- ^ Arguments passed to haddock program               } deriving (Eq,Show)  data HaddockOptsMonoid =-  HaddockOptsMonoid {toMonoidHaddockArgs :: ![String]+  HaddockOptsMonoid {hoMonoidAdditionalArgs :: ![String]                     } deriving (Show, Generic)  defaultHaddockOpts :: HaddockOpts-defaultHaddockOpts = HaddockOpts {toHaddockArgs = []}+defaultHaddockOpts = HaddockOpts {hoAdditionalArgs = []}  instance FromJSON (WithJSONWarnings HaddockOptsMonoid) where   parseJSON = withObjectWarnings "HaddockOptsMonoid"-    (\o -> do toMonoidHaddockArgs <- o ..:? toMonoidHaddockArgsName ..!= []+    (\o -> do hoMonoidAdditionalArgs <- o ..:? hoMonoidAdditionalArgsName ..!= []               return HaddockOptsMonoid{..})  instance Monoid HaddockOptsMonoid where   mempty = memptydefault   mappend = mappenddefault -toMonoidHaddockArgsName :: Text-toMonoidHaddockArgsName = "haddock-args"+hoMonoidAdditionalArgsName :: Text+hoMonoidAdditionalArgsName = "haddock-args"   -- | Options for the 'FinalAction' 'DoBenchmarks'
src/Stack/Types/Docker.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}@@ -8,17 +9,20 @@ module Stack.Types.Docker where  import Control.Applicative-import Control.Monad-import Control.Monad.Catch (MonadThrow)+import Control.Monad.Catch import Data.Aeson.Extended+import Data.List (intercalate) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T-import Distribution.Text (simpleParse)+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.Types.Version  -- | Docker configuration.@@ -91,9 +95,9 @@     -- ^ Volumes to mount in the container   ,dockerMonoidEnv :: ![String]     -- ^ Environment variables to set in the container-  ,dockerMonoidDatabasePath :: !(First String)+  ,dockerMonoidDatabasePath :: !(First (Path Abs File))     -- ^ Location of image usage database.-  ,dockerMonoidStackExe :: !(First String)+  ,dockerMonoidStackExe :: !(First DockerStackExe)     -- ^ Location of container-compatible stack executable   ,dockerMonoidSetUser :: !(First Bool)    -- ^ Set in-container user to match host's@@ -143,13 +147,22 @@     | DockerStackExePath (Path Abs File) -- ^ Executable at given path     deriving (Show) +instance FromJSON DockerStackExe where+    parseJSON a = do+        s <- parseJSON a+        case parseDockerStackExe s of+            Right dse -> return dse+            Left e -> fail (show e)+ -- | Parse 'DockerStackExe'. parseDockerStackExe :: (MonadThrow m) => String -> m DockerStackExe parseDockerStackExe t     | t == dockerStackExeDownloadVal = return DockerStackExeDownload     | t == dockerStackExeHostVal = return DockerStackExeHost     | t == dockerStackExeImageVal = return DockerStackExeImage-    | otherwise = liftM DockerStackExePath (parseAbsFile t)+    | otherwise = case parseAbsFile t of+        Just p -> return (DockerStackExePath p)+        Nothing -> throwM (DockerStackExeParseException t)  -- | Docker volume mount. data Mount = Mount String String@@ -188,6 +201,145 @@                              (return . VersionRangeJSON)                              (Distribution.Text.simpleParse (T.unpack s))) +-- | Exceptions thrown by Stack.Docker.+data StackDockerException+    = DockerMustBeEnabledException+      -- ^ Docker must be enabled to use the command.+    | OnlyOnHostException+      -- ^ Command must be run on host OS (not in a container).+    | InspectFailedException String+      -- ^ @docker inspect@ failed.+    | NotPulledException String+      -- ^ Image does not exist.+    | InvalidCleanupCommandException String+      -- ^ Input to @docker cleanup@ has invalid command.+    | InvalidImagesOutputException String+      -- ^ Invalid output from @docker images@.+    | InvalidPSOutputException String+      -- ^ Invalid output from @docker ps@.+    | InvalidInspectOutputException String+      -- ^ Invalid output from @docker inspect@.+    | PullFailedException String+      -- ^ Could not pull a Docker image.+    | DockerTooOldException Version Version+      -- ^ Installed version of @docker@ below minimum version.+    | DockerVersionProhibitedException [Version] Version+      -- ^ Installed version of @docker@ is prohibited.+    | BadDockerVersionException VersionRange Version+      -- ^ Installed version of @docker@ is out of range specified in config file.+    | InvalidVersionOutputException+      -- ^ Invalid output from @docker --version@.+    | HostStackTooOldException Version (Maybe Version)+      -- ^ Version of @stack@ on host is too old for version in image.+    | ContainerStackTooOldException Version Version+      -- ^ Version of @stack@ in container/image is too old for version on host.+    | CannotDetermineProjectRootException+      -- ^ Can't determine the project root (where to put docker sandbox).+    | DockerNotInstalledException+      -- ^ @docker --version@ failed.+    | UnsupportedStackExeHostPlatformException+      -- ^ Using host stack-exe on unsupported platform.+    | DockerStackExeParseException String+      -- ^ @stack-exe@ option fails to parse.+    deriving (Typeable)+instance Exception StackDockerException++instance Show StackDockerException where+    show DockerMustBeEnabledException =+        "Docker must be enabled in your configuration file to use this command."+    show OnlyOnHostException =+        "This command must be run on host OS (not in a Docker container)."+    show (InspectFailedException image) =+        concat ["'docker inspect' failed for image after pull: ",image,"."]+    show (NotPulledException image) =+        concat ["The Docker image referenced by your configuration file"+               ," has not\nbeen downloaded:\n    "+               ,image+               ,"\n\nRun '"+               ,unwords [stackProgName, dockerCmdName, dockerPullCmdName]+               ,"' to download it, then try again."]+    show (InvalidCleanupCommandException line) =+        concat ["Invalid line in cleanup commands: '",line,"'."]+    show (InvalidImagesOutputException line) =+        concat ["Invalid 'docker images' output line: '",line,"'."]+    show (InvalidPSOutputException line) =+        concat ["Invalid 'docker ps' output line: '",line,"'."]+    show (InvalidInspectOutputException msg) =+        concat ["Invalid 'docker inspect' output: ",msg,"."]+    show (PullFailedException image) =+        concat ["Could not pull Docker image:\n    "+               ,image+               ,"\nThere may not be an image on the registry for your resolver's LTS version in\n"+               ,"your configuration file."]+    show (DockerTooOldException minVersion haveVersion) =+        concat ["Minimum docker version '"+               ,versionString minVersion+               ,"' is required by "+               ,stackProgName+               ," (you have '"+               ,versionString haveVersion+               ,"')."]+    show (DockerVersionProhibitedException prohibitedVersions haveVersion) =+        concat ["These Docker versions are incompatible with "+               ,stackProgName+               ," (you have '"+               ,versionString haveVersion+               ,"'): "+               ,intercalate ", " (map versionString prohibitedVersions)+               ,"."]+    show (BadDockerVersionException requiredRange haveVersion) =+        concat ["The version of 'docker' you are using ("+               ,show haveVersion+               ,") is outside the required\n"+               ,"version range specified in stack.yaml ("+               ,T.unpack (versionRangeText requiredRange)+               ,")."]+    show InvalidVersionOutputException =+        "Cannot get Docker version (invalid 'docker --version' output)."+    show (HostStackTooOldException minVersion (Just hostVersion)) =+        concat ["The host's version of '"+               ,stackProgName+               ,"' is too old for this Docker image.\nVersion "+               ,versionString minVersion+               ," is required; you have "+               ,versionString hostVersion+               ,"."]+    show (HostStackTooOldException minVersion Nothing) =+        concat ["The host's version of '"+               ,stackProgName+               ,"' is too old.\nVersion "+               ,versionString minVersion+               ," is required."]+    show (ContainerStackTooOldException requiredVersion containerVersion) =+        concat ["The Docker container's version of '"+               ,stackProgName+               ,"' is too old.\nVersion "+               ,versionString requiredVersion+               ," is required; the container has "+               ,versionString containerVersion+               ,"."]+    show CannotDetermineProjectRootException =+        "Cannot determine project root directory for Docker sandbox."+    show DockerNotInstalledException =+        "Cannot find 'docker' in PATH.  Is Docker installed?"+    show UnsupportedStackExeHostPlatformException = concat+        [ "Using host's "+        , stackProgName+        , " executable in Docker container is only supported on "+        , display dockerContainerPlatform+        , " platform" ]+    show (DockerStackExeParseException s) = concat+        [ "Failed to parse "+        , show s+        , ". Expected "+        , show dockerStackExeDownloadVal+        , ", "+        , show dockerStackExeHostVal+        , ", "+        , show dockerStackExeImageVal+        , " or absolute path to executable."+        ]+ -- | Docker enable argument name. dockerEnableArgName :: Text dockerEnableArgName = "enable"@@ -271,3 +423,26 @@ -- | Argument name used to pass docker entrypoint data (only used internally) dockerEntrypointArgName :: String dockerEntrypointArgName = "internal-docker-entrypoint"++-- | Command-line argument for "docker"+dockerCmdName :: String+dockerCmdName = "docker"++dockerHelpOptName :: String+dockerHelpOptName = dockerCmdName ++ "-help"++-- | Command-line argument for @docker pull@.+dockerPullCmdName :: String+dockerPullCmdName = "pull"++-- | Command-line argument for @docker cleanup@.+dockerCleanupCmdName :: String+dockerCleanupCmdName = "cleanup"++-- | Command-line option for @--internal-re-exec-version@.+reExecArgName :: String+reExecArgName = "internal-re-exec-version"++-- | Platform that Docker containers run+dockerContainerPlatform :: Platform+dockerContainerPlatform = Platform X86_64 Linux
src/Stack/Types/FlagName.hs view
@@ -22,16 +22,17 @@   where  import           Control.Applicative+import           Control.DeepSeq (NFData) import           Control.Monad.Catch import           Data.Aeson.Extended-import           Data.Attoparsec.Text import           Data.Attoparsec.Combinators-import           Data.Binary.VersionTagged+import           Data.Attoparsec.Text import           Data.Char (isLetter, isDigit, toLower) import           Data.Data import           Data.Hashable import           Data.Map (Map) import qualified Data.Map as Map+import           Data.Store (Store) import           Data.Text (Text) import qualified Data.Text as T import           Data.Text.Binary ()@@ -51,8 +52,7 @@ -- | A flag name. newtype FlagName =   FlagName Text-  deriving (Typeable,Data,Generic,Hashable,Binary,NFData)-instance HasStructuralInfo FlagName+  deriving (Typeable,Data,Generic,Hashable,Store,NFData) instance Eq FlagName where     x == y = compare x y == EQ instance Ord FlagName where
src/Stack/Types/GhcPkgId.hs view
@@ -11,13 +11,15 @@   where  import           Control.Applicative+import           Control.DeepSeq import           Control.Monad.Catch import           Data.Aeson.Extended import           Data.Attoparsec.Text-import           Data.Binary (getWord8, putWord8)-import           Data.Binary.VersionTagged+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@@ -52,6 +54,7 @@         fmap GhcPkgId get instance NFData GhcPkgId instance HasStructuralInfo GhcPkgId+instance Store GhcPkgId  instance Show GhcPkgId where   show = show . ghcPkgIdString
src/Stack/Types/Image.hs view
@@ -14,6 +14,7 @@ import Data.Text (Text) import GHC.Generics (Generic) import Generics.Deriving.Monoid (mappenddefault, memptydefault)+import Path import Prelude -- Fix redundant import warnings  -- | Image options. Currently only Docker image options.@@ -29,12 +30,12 @@     , imgDockerEntrypoints :: !(Maybe [String])       -- ^ Maybe have a specific ENTRYPOINT list that will be used to       -- create images.-    , imgDockerAdd :: !(Map FilePath FilePath)+    , imgDockerAdd :: !(Map FilePath (Path Abs Dir))       -- ^ Maybe have some static project content to include in a       -- specific directory in all the images.     , imgDockerImageName :: !(Maybe String)       -- ^ Maybe have a name for the image we are creating-    , imgDockerExecutables :: !(Maybe [FilePath])+    , imgDockerExecutables :: !(Maybe [Path Rel File])       -- ^ Filenames of executables to add (if Nothing, add them all)     } deriving (Show)
src/Stack/Types/Internal.hs view
@@ -17,6 +17,7 @@   Env {envConfig :: !config       ,envLogLevel :: !LogLevel       ,envTerminal :: !Bool+      ,envAnsiTerminal :: !Bool       ,envReExec :: !Bool       ,envManager :: !Manager       ,envSticky :: !Sticky@@ -50,9 +51,11 @@  class HasTerminal r where   getTerminal :: r -> Bool+  getAnsiTerminal :: r -> Bool  instance HasTerminal (Env config) where   getTerminal = envTerminal+  getAnsiTerminal = envAnsiTerminal  class HasReExec r where   getReExec :: r -> Bool
src/Stack/Types/Nix.hs view
@@ -9,8 +9,8 @@  import Control.Applicative import Data.Aeson.Extended-import Data.Text (Text) import Data.Monoid+import Data.Text (Text) import GHC.Generics (Generic) import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Prelude
src/Stack/Types/Package.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-} -- |  module Stack.Types.Package where@@ -13,8 +15,6 @@ import           Control.Monad.IO.Class import           Control.Monad.Logger (MonadLogger) import           Control.Monad.Reader-import           Data.Binary-import           Data.Binary.VersionTagged import qualified Data.ByteString as S import           Data.Data import           Data.Function@@ -25,9 +25,13 @@ 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.ModuleName (ModuleName) import           Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier)@@ -347,17 +351,19 @@     , fciSize :: !Word64     , fciHash :: !S.ByteString     }-    deriving (Generic, Show)-instance Binary FileCacheInfo-instance HasStructuralInfo FileCacheInfo+    deriving (Generic, Show, Eq, Data, Typeable)+instance Store FileCacheInfo instance NFData FileCacheInfo  -- | Used for storage and comparison. newtype ModTime = ModTime (Integer,Rational)-  deriving (Ord,Show,Generic,Eq,NFData,Binary)+  deriving (Ord, Show, Generic, Eq, NFData, Store, Data, Typeable) -instance HasStructuralInfo ModTime-instance HasSemanticVersion ModTime+modTimeVC :: VersionConfig ModTime+modTimeVC = storeVersionConfig "mod-time-v1" "UBECpUI0JvM_SBOnRNdaiF9_yOU="++testSuccessVC :: VersionConfig Bool+testSuccessVC = storeVersionConfig "test-v1" "jC_GB0SGtbpRQbDlm7oQJP7thu8="  -- | A descriptor from a .cabal file indicating one of the following: --
+ src/Stack/Types/PackageDump.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Stack.Types.PackageDump+    ( InstalledCache(..)+    , InstalledCacheInner(..)+    , InstalledCacheEntry(..)+    , 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.Types.GhcPkgId+import Stack.Types.PackageIdentifier++-- | Cached information on whether package have profiling libraries and haddocks.+newtype InstalledCache = InstalledCache (IORef InstalledCacheInner)+newtype InstalledCacheInner = InstalledCacheInner (Map GhcPkgId InstalledCacheEntry)+    deriving (Store, Generic, Eq, Show, Data, Typeable)++-- | Cached information on whether a package has profiling libraries and haddocks.+data InstalledCacheEntry = InstalledCacheEntry+    { installedCacheProfiling :: !Bool+    , installedCacheHaddock :: !Bool+    , installedCacheIdent :: !PackageIdentifier }+    deriving (Eq, Generic, Show, Data, Typeable)+instance Store InstalledCacheEntry++installedCacheVC :: VersionConfig InstalledCacheInner+installedCacheVC = storeVersionConfig "installed-v1" "5yL7Ngpy4YKWDDCTUI6zAJ9UySI="
src/Stack/Types/PackageIdentifier.hs view
@@ -22,9 +22,9 @@ import           Control.Monad.Catch (MonadThrow, throwM) import           Data.Aeson.Extended import           Data.Attoparsec.Text-import           Data.Binary.VersionTagged (Binary, HasStructuralInfo) import           Data.Data import           Data.Hashable+import           Data.Store (Store) import           Data.Text (Text) import qualified Data.Text as T import           GHC.Generics@@ -53,8 +53,7 @@       seq (rnf p) (rnf v)  instance Hashable PackageIdentifier-instance Binary PackageIdentifier-instance HasStructuralInfo PackageIdentifier+instance Store PackageIdentifier  instance Show PackageIdentifier where   show = show . packageIdentifierString
src/Stack/Types/PackageIndex.hs view
@@ -1,25 +1,38 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}  module Stack.Types.PackageIndex     ( PackageDownload (..)     , PackageCache (..)     , PackageCacheMap (..)+    -- ** PackageIndex, IndexName & IndexLocation+    , PackageIndex(..)+    , IndexName(..)+    , indexNameText+    , IndexLocation(..)     ) where +import           Control.DeepSeq (NFData) import           Control.Monad (mzero) import           Data.Aeson.Extended-import qualified Data.Binary as Binary-import           Data.Binary.VersionTagged import           Data.ByteString (ByteString)+import           Data.Hashable (Hashable)+import           Data.Data (Data, Typeable) import           Data.Int (Int64) import           Data.Map (Map) import qualified Data.Map.Strict as Map+import           Data.Store (Store) import           Data.Text (Text)-import           Data.Text.Encoding (encodeUtf8)+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.PackageIdentifier  data PackageCache = PackageCache@@ -29,25 +42,21 @@     -- ^ size in bytes of the .cabal file     , pcDownload :: !(Maybe PackageDownload)     }-    deriving (Generic)+    deriving (Generic, Eq, Show, Data, Typeable) -instance Binary PackageCache+instance Store PackageCache instance NFData PackageCache-instance HasStructuralInfo PackageCache  newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache)-    deriving (Generic, Binary, NFData)-instance HasStructuralInfo PackageCacheMap-instance HasSemanticVersion PackageCacheMap+    deriving (Generic, Store, NFData, Eq, Show, Data, Typeable)  data PackageDownload = PackageDownload     { pdSHA512 :: !ByteString     , pdUrl    :: !ByteString     , pdSize   :: !Word64     }-    deriving (Show, Generic)-instance Binary.Binary PackageDownload-instance HasStructuralInfo PackageDownload+    deriving (Show, Generic, Eq, Data, Typeable)+instance Store PackageDownload instance NFData PackageDownload instance FromJSON PackageDownload where     parseJSON = withObject "Package" $ \o -> do@@ -63,4 +72,61 @@             { pdSHA512 = encodeUtf8 sha512             , pdUrl = encodeUtf8 url             , pdSize = size+            }++-- | Unique name for a package index+newtype IndexName = IndexName { unIndexName :: ByteString }+    deriving (Show, Eq, Ord, Hashable, Store)+indexNameText :: IndexName -> Text+indexNameText = decodeUtf8 . unIndexName+instance ToJSON IndexName where+    toJSON = toJSON . indexNameText++instance FromJSON IndexName where+    parseJSON = withText "IndexName" $ \t ->+        case parseRelDir (T.unpack t) of+            Left e -> fail $ "Invalid index name: " ++ show e+            Right _ -> return $ IndexName $ encodeUtf8 t++-- | Location of the package index. This ensures that at least one of Git or+-- HTTP is available.+data IndexLocation = ILGit !Text | ILHttp !Text | ILGitHttp !Text !Text+    deriving (Show, Eq, Ord)+++-- | Information on a single package index+data PackageIndex = PackageIndex+    { indexName :: !IndexName+    , indexLocation :: !IndexLocation+    , indexDownloadPrefix :: !Text+    -- ^ URL prefix for downloading packages+    , indexGpgVerify :: !Bool+    -- ^ GPG-verify the package index during download. Only applies to Git+    -- repositories for now.+    , indexRequireHashes :: !Bool+    -- ^ Require that hashes and package size information be available for packages in this index+    }+    deriving Show+instance FromJSON (WithJSONWarnings PackageIndex) where+    parseJSON = withObjectWarnings "PackageIndex" $ \o -> do+        name <- o ..: "name"+        prefix <- o ..: "download-prefix"+        mgit <- o ..:? "git"+        mhttp <- o ..:? "http"+        loc <-+            case (mgit, mhttp) of+                (Nothing, Nothing) -> fail $+                    "Must provide either Git or HTTP URL for " +++                    T.unpack (indexNameText name)+                (Just git, Nothing) -> return $ ILGit git+                (Nothing, Just http) -> return $ ILHttp http+                (Just git, Just http) -> return $ ILGitHttp git http+        gpgVerify <- o ..:? "gpg-verify" ..!= False+        reqHashes <- o ..:? "require-hashes" ..!= False+        return PackageIndex+            { indexName = name+            , indexLocation = loc+            , indexDownloadPrefix = prefix+            , indexGpgVerify = gpgVerify+            , indexRequireHashes = reqHashes             }
src/Stack/Types/PackageName.hs view
@@ -28,14 +28,14 @@ import           Control.Monad import           Control.Monad.Catch import           Data.Aeson.Extended-import           Data.Attoparsec.Text import           Data.Attoparsec.Combinators-import           Data.Binary.VersionTagged (Binary, HasStructuralInfo)+import           Data.Attoparsec.Text import           Data.Data import           Data.Hashable import           Data.List (intercalate) import           Data.Map (Map) import qualified Data.Map as Map+import           Data.Store (Store) import           Data.Text (Text) import qualified Data.Text as T import           Data.Text.Binary ()@@ -43,8 +43,8 @@ import           GHC.Generics import           Language.Haskell.TH import           Language.Haskell.TH.Syntax-import           Path import qualified Options.Applicative as O+import           Path  -- | A parse fail. data PackageNameParseFail@@ -61,7 +61,7 @@ -- | A package name. newtype PackageName =   PackageName Text-  deriving (Eq,Ord,Typeable,Data,Generic,Hashable,Binary,NFData)+  deriving (Eq,Ord,Typeable,Data,Generic,Hashable,NFData,Store)  instance Lift PackageName where   lift (PackageName n) =@@ -70,8 +70,6 @@  instance Show PackageName where   show (PackageName n) = T.unpack n--instance HasStructuralInfo PackageName  instance ToJSON PackageName where     toJSON = toJSON . packageNameText
src/Stack/Types/StackT.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -- | The monad used for the command-line executable @stack@.@@ -33,10 +34,11 @@ import           Control.Monad.Catch import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.Reader+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)@@ -47,11 +49,14 @@ import           Data.Time import           GHC.Foreign (withCString, peekCString) import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax (lift) import           Network.HTTP.Client.Conduit (HasHttpManager(..)) import           Network.HTTP.Conduit import           Prelude -- Fix AMP warning-import           Stack.Types.Internal+import           System.FilePath import           Stack.Types.Config (GlobalOpts (..))+import           Stack.Types.Internal+import           System.Console.ANSI import           System.IO import           System.Log.FastLogger @@ -83,9 +88,12 @@     restoreT = defaultRestoreT StackT  -- | Takes the configured log level into account.-instance (MonadIO m) => MonadLogger (StackT config m) where-  monadLoggerLog = stickyLoggerFunc+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)                 => Manager -> config -> GlobalOpts -> StackT config m a -> m a@@ -96,13 +104,14 @@ runStackT :: (MonadIO m)           => Manager -> LogLevel -> config -> Bool -> Bool -> StackT config m a -> m a runStackT manager logLevel config terminal reExec m = do+    ansiTerminal <- liftIO $ hSupportsANSI stderr     canUseUnicode <- liftIO getCanUseUnicode     withSticky         terminal         (\sticky ->               runReaderT                   (unStackT m)-                  (Env config logLevel terminal reExec manager sticky canUseUnicode))+                  (Env config logLevel terminal ansiTerminal reExec manager sticky canUseUnicode))  -- | Taken from GHC: determine if we should use Unicode syntax getCanUseUnicode :: IO Bool@@ -121,6 +130,7 @@ data LoggingEnv = LoggingEnv     { lenvLogLevel :: !LogLevel     , lenvTerminal :: !Bool+    , lenvAnsiTerminal :: !Bool     , lenvReExec :: !Bool     , lenvManager :: !Manager     , lenvSticky :: !Sticky@@ -160,6 +170,7 @@  instance HasTerminal LoggingEnv where     getTerminal = lenvTerminal+    getAnsiTerminal = lenvAnsiTerminal  instance HasReExec LoggingEnv where     getReExec = lenvReExec@@ -195,6 +206,7 @@ runStackLoggingT :: MonadIO m                  => Manager -> LogLevel -> Bool -> Bool -> StackLoggingT m a -> m a runStackLoggingT manager logLevel terminal reExec m = do+    ansiTerminal <- liftIO $ hSupportsANSI stderr     canUseUnicode <- liftIO getCanUseUnicode     withSticky         terminal@@ -206,6 +218,7 @@                   , lenvManager = manager                   , lenvSticky = sticky                   , lenvTerminal = terminal+                  , lenvAnsiTerminal = ansiTerminal                   , lenvReExec = reExec                   , lenvSupportsUnicode = canUseUnicode                   })@@ -216,13 +229,33 @@  -------------------------------------------------------------------------------- -- Logging functionality-stickyLoggerFunc :: (HasSticky r, HasLogLevel r, HasSupportsUnicode r, ToLogStr msg, MonadReader r m, MonadIO m)-                 => Loc -> LogSource -> LogLevel -> msg -> m ()+stickyLoggerFunc+    :: (HasSticky r, HasLogLevel r, HasSupportsUnicode r, HasTerminal r, ToLogStr msg, MonadReader r m, MonadIO m)+    => Loc -> LogSource -> LogLevel -> msg -> m () stickyLoggerFunc loc src level msg = do-    Sticky mref <- asks getSticky+    func <- getStickyLoggerFunc+    liftIO $ func loc src level msg++getStickyLoggerFunc+    :: (HasSticky r, HasLogLevel r, HasSupportsUnicode r, HasTerminal r, ToLogStr msg, MonadReader r m)+    => m (Loc -> LogSource -> LogLevel -> msg -> IO ())+getStickyLoggerFunc = do+    sticky <- asks getSticky+    logLevel <- asks getLogLevel+    supportsUnicode <- asks getSupportsUnicode+    supportsAnsi <- asks getAnsiTerminal+    return $ stickyLoggerFuncImpl sticky logLevel supportsUnicode supportsAnsi++stickyLoggerFuncImpl+    :: ToLogStr msg+    => Sticky -> LogLevel -> Bool -> Bool+    -> (Loc -> LogSource -> LogLevel -> msg -> IO ())+stickyLoggerFuncImpl (Sticky mref) maxLogLevel supportsUnicode supportsAnsi loc src level msg =     case mref of         Nothing ->             loggerFunc+                supportsAnsi+                maxLogLevel                 out                 loc                 src@@ -232,22 +265,15 @@                      _ -> level)                 msg         Just ref -> do-            sticky <- liftIO (takeMVar ref)-            let backSpaceChar =-                    '\8'-                repeating =-                    S8.replicate-                        (maybe 0 T.length sticky)-                clear =-                    liftIO-                        (S8.hPutStr out-                             (repeating backSpaceChar <>-                              repeating ' ' <>-                              repeating backSpaceChar))-            maxLogLevel <- asks getLogLevel+            sticky <- takeMVar ref+            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-            supportsUnicode <- asks getSupportsUnicode             let msgText                     | supportsUnicode = msgTextRaw                     | otherwise = T.map replaceUnicode msgTextRaw@@ -256,25 +282,27 @@                 case level of                     LevelOther "sticky-done" -> do                         clear-                        liftIO (T.hPutStrLn out msgText >> hFlush out)+                        T.hPutStrLn out msgText+                        hFlush out                         return Nothing                     LevelOther "sticky" -> do                         clear-                        liftIO (T.hPutStr out msgText >> hFlush out)+                        T.hPutStr out msgText+                        hFlush out                         return (Just msgText)                     _                       | level >= maxLogLevel -> do                           clear-                          loggerFunc out loc src level $ toLogStr msgText+                          loggerFunc supportsAnsi maxLogLevel out loc src level $ toLogStr msgText                           case sticky of                               Nothing ->                                   return Nothing                               Just line -> do-                                  liftIO (T.hPutStr out line >> hFlush out)+                                  T.hPutStr out line >> hFlush out                                   return sticky                       | otherwise ->                           return sticky-            liftIO (putMVar ref newState)+            putMVar ref newState   where     out = stderr     msgTextRaw = T.decodeUtf8With T.lenientDecode msgBytes@@ -287,48 +315,67 @@ replaceUnicode c = c  -- | Logging function takes the log level into account.-loggerFunc :: (MonadIO m,ToLogStr msg,MonadReader r m,HasLogLevel r)-           => Handle -> Loc -> Text -> LogLevel -> msg -> m ()-loggerFunc outputChannel loc _src level msg =-  do maxLogLevel <- asks getLogLevel-     when (level >= maxLogLevel)-          (liftIO (do out <- getOutput maxLogLevel-                      T.hPutStrLn outputChannel out))-  where getOutput maxLogLevel =-          do timestamp <- getTimestamp-             l <- getLevel-             lc <- getLoc-             return (T.pack timestamp <> T.pack l <> T.decodeUtf8 (fromLogStr (toLogStr msg)) <> T.pack lc)-          where getTimestamp-                  | maxLogLevel <= LevelDebug =-                    do now <- getZonedTime-                       return (formatTime' now ++ ": ")-                  | otherwise = return ""-                  where-                    formatTime' =-                        take timestampLength . formatTime defaultTimeLocale "%F %T.%q"-                getLevel-                  | maxLogLevel <= LevelDebug =-                    return ("[" ++-                            map toLower (drop 5 (show level)) ++-                            "] ")-                  | otherwise = return ""-                getLoc-                  | maxLogLevel <= LevelDebug =-                    return (" @(" ++ fileLocStr ++ ")")-                  | otherwise = return ""-                fileLocStr =-                  loc_package loc ++-                  ':' :-                  loc_module loc ++-                  ' ' :-                  loc_filename loc ++-                  ':' :-                  line loc ++-                  ':' :-                  char loc-                  where line = show . fst . loc_start-                        char = show . snd . loc_start+loggerFunc :: ToLogStr msg+           => Bool -> LogLevel -> Handle -> Loc -> Text -> LogLevel -> msg -> IO ()+loggerFunc supportsAnsi maxLogLevel outputChannel loc _src level msg =+   when (level >= maxLogLevel)+        (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 | supportsAnsi = setSGRCode xs+               | otherwise = ""+       getTimestamp+         | maxLogLevel <= LevelDebug =+           do now <- getZonedTime+              return $+                  ansi [SetColor Foreground Vivid Black]+                  ++ formatTime' now ++ ": "+         | otherwise = return ""+         where+           formatTime' =+               take timestampLength . formatTime defaultTimeLocale "%F %T.%q"+       getLevel+         | maxLogLevel <= LevelDebug =+           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+         | maxLogLevel <= LevelDebug =+           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.
src/Stack/Types/TemplateName.hs view
@@ -17,7 +17,7 @@ import qualified Data.Text as T import           Data.Yaml (Value(Object), (.:?)) import           Language.Haskell.TH-import           Network.HTTP.Client (parseUrl)+import           Network.HTTP.Client (parseRequest) import qualified Options.Applicative as O import           Path import           Path.Internal@@ -83,7 +83,7 @@                                            $ asum (validParses prefix hsf orig)     validParses prefix hsf orig =         -- NOTE: order is important-        [ TemplateName (T.pack orig) . UrlPath <$> (parseUrl orig *> Just orig)+        [ TemplateName (T.pack orig) . UrlPath <$> (parseRequest orig *> Just orig)         , TemplateName prefix        . AbsPath <$> parseAbsFile hsf         , TemplateName prefix        . RelPath <$> parseRelFile hsf         ]
src/Stack/Types/Version.hs view
@@ -35,7 +35,6 @@ import           Control.Monad.Catch import           Data.Aeson.Extended import           Data.Attoparsec.Text-import           Data.Binary.VersionTagged (Binary, HasStructuralInfo) import           Data.Data import           Data.Hashable import           Data.List@@ -45,10 +44,9 @@ 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.Text.Binary ()-import           Data.Vector.Binary () import           Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V import           Data.Word@@ -71,8 +69,7 @@ -- | A package version. newtype Version =   Version {unVersion :: Vector Word}-  deriving (Eq,Ord,Typeable,Data,Generic,Binary,NFData)-instance HasStructuralInfo Version+  deriving (Eq,Ord,Typeable,Data,Generic,Store,NFData)  instance Hashable Version where   hashWithSalt i = hashWithSalt i . V.toList . unVersion
src/Stack/Upgrade.hs view
@@ -25,7 +25,10 @@ import           Stack.Fetch import           Stack.PackageIndex import           Stack.Setup-import           Stack.Types+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName+import           Stack.Types.Version+import           Stack.Types.Config import           Stack.Types.Internal import           Stack.Types.StackT import           System.Process              (readProcess)
src/Stack/Upload.hs view
@@ -48,8 +48,8 @@                                                         Response,                                                         RequestBody(RequestBodyLBS),                                                         applyBasicAuth, brRead,-                                                        checkStatus, newManager,-                                                        parseUrl,+                                                        newManager,+                                                        parseRequest,                                                         requestHeaders,                                                         responseBody,                                                         responseStatus,@@ -59,7 +59,7 @@ import           Network.HTTP.Types                    (statusCode) import           Path                                  (toFilePath) import           Prelude -- Fix redundant import warnings-import           Stack.Types+import           Stack.Types.Config import           System.Directory                      (createDirectoryIfMissing,                                                         removeFile) import           System.FilePath                       ((</>), takeFileName)@@ -195,10 +195,9 @@     manager <- usGetManager us     (creds, fromFile') <- loadCreds $ usCredsSource us config     when (not fromFile' && usSaveCreds us) $ saveCreds config creds-    req0 <- parseUrl $ usUploadUrl us+    req0 <- parseRequest $ usUploadUrl us     let req1 = req0             { requestHeaders = [("Accept", "text/plain")]-            , checkStatus = \_ _ _ -> Nothing             }     return Uploader         { upload_ = \tarName bytes -> do
src/System/Process/Log.hs view
@@ -1,18 +1,21 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}  -- | Separate module because TH.  module System.Process.Log     (logCreateProcess-    ,logProcessRun+    ,withProcessTimeLog     ,showProcessArgDebug)     where  import           Control.Monad.Logger+import           Control.Monad.IO.Class import           Data.Monoid import           Data.Text (Text) import qualified Data.Text as T import           Language.Haskell.TH+import qualified System.Clock as Clock import           System.Process (CreateProcess(..), CmdSpec(..))  -- | Log running a process with its arguments, for debugging (-v).@@ -30,16 +33,30 @@       in f|]  -- | Log running a process with its arguments, for debugging (-v).-logProcessRun :: Q Exp-logProcessRun =-    [|let f :: MonadLogger m => String -> [String] -> m ()-          f name args =+--+-- 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               $logDebug-                  ("Run process: " <> T.pack name <> " " <>-                   T.intercalate-                       " "-                       (map showProcessArgDebug args))+                  ("Process finished in " <> timeSpecMilliSecondText diff <>+                   ": " <> cmdText)+              return x       in f|]++timeSpecMilliSecondText :: Clock.TimeSpec -> Text+timeSpecMilliSecondText t =+    (T.pack . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> " ms"  -- | Show a process arg including speechmarks when necessary. Just for -- debugging purposes, not functionally important.
src/System/Process/Read.hs view
@@ -28,11 +28,10 @@   ,envSearchPath   ,preProcess   ,readProcessNull-  ,readInNull-  ,logProcessRun   ,ReadProcessException (..)   ,augmentPath   ,augmentPathMap+  ,resetExeCache   )   where @@ -51,11 +50,10 @@ import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import           Data.Conduit.Process hiding (callProcess)-import           Data.Foldable (forM_) import           Data.IORef import           Data.Map (Map) import qualified Data.Map as Map-import           Data.Maybe (isJust, maybeToList)+import           Data.Maybe (isJust, maybeToList, fromMaybe) import           Data.Monoid import           Data.Text (Text) import qualified Data.Text as T@@ -66,6 +64,7 @@ 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@@ -81,7 +80,7 @@     , eoStringList :: [(String, String)] -- ^ Environment variables as association list     , eoPath :: [FilePath] -- ^ List of directories searched for executables (@PATH@)     , eoExeCache :: IORef (Map FilePath (Either ReadProcessException (Path Abs File)))-    , eoExeExtension :: String -- ^ @""@ or @".exe"@, depending on the platform+    , eoExeExtensions :: [String] -- ^ @[""]@ on non-Windows systems, @["", ".exe", ".bat"]@ on Windows     , eoPlatform :: Platform     } @@ -112,9 +111,17 @@     return EnvOverride         { eoTextMap = tm         , eoStringList = map (T.unpack *** T.unpack) $ Map.toList tm-        , eoPath = maybe [] (FP.splitSearchPath . T.unpack) (Map.lookup "PATH" tm)+        , eoPath =+             (if isWindows then (".":) else id)+             (maybe [] (FP.splitSearchPath . T.unpack) (Map.lookup "PATH" tm))         , eoExeCache = ref-        , eoExeExtension = if isWindows then ".exe" else ""+        , eoExeExtensions =+            if isWindows+                then let pathext = fromMaybe+                           ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC"+                           (Map.lookup "PATHEXT" tm)+                      in map T.unpack $ "" : T.splitOn ";" pathext+                else [""]         , eoPlatform = platform         }   where@@ -135,6 +142,8 @@ envHelper = Just . eoStringList  -- | 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)                 => Maybe (Path Abs Dir) -- ^ Optional working directory                 -> EnvOverride@@ -144,26 +153,6 @@ readProcessNull wd menv name args =     sinkProcessStdout wd menv name args CL.sinkNull --- | Run the given command in the given directory. If it exits with anything--- but success, print an error and then call 'exitWith' to exit the program.-readInNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)-           => Path Abs Dir -- ^ Directory to run in-           -> FilePath -- ^ Command to run-           -> EnvOverride-           -> [String] -- ^ Command line arguments-           -> Maybe Text -- ^ Optional additional error message-           -> m ()-readInNull wd cmd menv args errMsg = do-    result <- try (readProcessNull (Just wd) menv cmd args)-    case result of-        Left ex -> do-            $logError (T.pack (show ex))-            case ex of-                ReadProcessException{} -> forM_ errMsg $logError-                _ -> return ()-            liftIO exitFailure-        Right () -> return ()- -- | Try to produce a strict 'S.ByteString' from the stdout of a -- process. tryProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)@@ -177,7 +166,7 @@  -- | Produce a strict 'S.ByteString' from the stdout of a process. ----- Throws a 'ReadProcessException' exception if the  process fails.+-- Throws a 'ReadProcessException' exception if the process fails. readProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)                   => Maybe (Path Abs Dir) -- ^ Optional directory to run in                   -> EnvOverride@@ -228,6 +217,8 @@ -- If the process fails, spits out stdout and stderr as error log -- level. Should not be used for long-running processes or ones with -- lots of output; for that use 'sinkProcessStdoutLogStderr'.+--+-- Throws a 'ReadProcessException' if unsuccessful. sinkProcessStdout     :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)     => Maybe (Path Abs Dir) -- ^ Optional directory to run in@@ -271,6 +262,8 @@     void $ restore $ sinkProcessStderrStdout mdir menv name args logLines logLines  -- | Consume the stdout and stderr of a process feeding strict 'S.ByteString's to the consumers.+--+-- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ProcessExitedUnsuccessfully' if the process itself fails. sinkProcessStderrStdout :: forall m e o. (MonadIO m, MonadLogger m)                         => Maybe (Path Abs Dir) -- ^ Optional directory to run in                         -> EnvOverride@@ -280,15 +273,18 @@                         -> Sink S.ByteString IO o -- ^ Sink for stdout                         -> m (e,o) sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout = do-  $logProcessRun name args   name' <- preProcess wd menv name-  liftIO $ withCheckedProcess-      (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }-      (\ClosedStream out err -> f err out)+  $withProcessTimeLog name' args $+      liftIO $ withCheckedProcess+          (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }+          (\ClosedStream out err -> f err out)   where     f :: Source IO S.ByteString -> Source IO S.ByteString -> IO (e, o)     f err out = (err $$ sinkStderr) `concurrently` (out $$ sinkStdout) +-- | Like sinkProcessStderrStdout, but receives Handles for stderr and stdout instead of 'Sink's.+--+-- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ProcessExitedUnsuccessfully' if the process itself fails. sinkProcessStderrStdoutHandle :: (MonadIO m, MonadLogger m)                               => Maybe (Path Abs Dir) -- ^ Optional directory to run in                               -> EnvOverride@@ -298,19 +294,21 @@                               -> Handle                               -> m () sinkProcessStderrStdoutHandle wd menv name args err out = do-  $logProcessRun name args   name' <- preProcess wd menv name-  liftIO $ withCheckedProcess-      (proc name' args)-          { env = envHelper menv-          , cwd = fmap toFilePath wd-          , std_err = UseHandle err-          , std_out = UseHandle out-          }-      (\ClosedStream UseProvidedHandle UseProvidedHandle -> return ())+  $withProcessTimeLog name' args $+      liftIO $ withCheckedProcess+          (proc name' args)+              { env = envHelper menv+              , cwd = fmap toFilePath wd+              , std_err = UseHandle err+              , std_out = UseHandle out+              }+          (\ClosedStream UseProvidedHandle UseProvidedHandle -> return ())  -- | Perform pre-call-process tasks.  Ensure the working directory exists and find the -- executable path.+--+-- Throws a 'ReadProcessException' if unsuccessful. preProcess :: (MonadIO m)   => Maybe (Path Abs Dir) -- ^ Optional directory to create if necessary   -> EnvOverride       -- ^ How to override environment@@ -336,10 +334,7 @@   -> String            -- ^ Name of executable   -> m (n (Path Abs File)) -- ^ Full path to that executable on success findExecutable eo name0 | any FP.isPathSeparator name0 = do-    let names0-            | null (eoExeExtension eo) = [name0]-            -- Support `stack exec foo/bar.exe` on Windows-            | otherwise = [name0 ++ eoExeExtension eo, name0]+    let names0 = map (name0 ++) (eoExeExtensions eo)         testNames [] = return $ throwM $ ExecutableNotFoundAt name0         testNames (name:names) = do             exists <- liftIO $ D.doesFileExist name@@ -357,14 +352,12 @@             let loop [] = return $ Left $ ExecutableNotFound name (eoPath eo)                 loop (dir:dirs) = do                     let fp0 = dir FP.</> name-                        fps0-                            | null (eoExeExtension eo) = [fp0]-                            -- Support `stack exec foo.exe` on Windows-                            | otherwise = [fp0 ++ eoExeExtension eo, fp0]+                        fps0 = map (fp0 ++) (eoExeExtensions eo)                         testFPs [] = loop dirs                         testFPs (fp:fps) = do                             exists <- D.doesFileExist fp-                            if exists+                            existsExec <- if exists then liftM D.executable $ D.getPermissions fp else return False+                            if existsExec                                 then do                                     fp' <- D.makeAbsolute fp >>= parseAbsFile                                     return $ return fp'@@ -376,6 +369,10 @@             return epath     return $ either throwM return epath +-- | Reset the executable cache.+resetExeCache :: MonadIO m => EnvOverride -> m ()+resetExeCache eo = liftIO (atomicModifyIORef (eoExeCache eo) (const mempty))+ -- | Load up an 'EnvOverride' from the standard environment. getEnvOverride :: MonadIO m => Platform -> m EnvOverride getEnvOverride platform =@@ -397,16 +394,16 @@         ] ++ paths  -- | Augment the PATH environment variable with the given extra paths.-augmentPath :: MonadThrow m => [FilePath] -> Maybe Text -> m Text+augmentPath :: MonadThrow m => [Path Abs Dir] -> Maybe Text -> m Text augmentPath dirs mpath =-  do let illegal = filter (FP.searchPathSeparator `elem`) dirs+  do let illegal = filter (FP.searchPathSeparator `elem`) (map toFilePath dirs)      unless (null illegal) (throwM $ PathsInvalidInPath illegal)      return $ T.intercalate (T.singleton FP.searchPathSeparator)-            $ map (T.pack . FP.dropTrailingPathSeparator) dirs+            $ map (T.pack . toFilePathNoTrailingSep) dirs             ++ maybeToList mpath  -- | Apply 'augmentPath' on the PATH value in the given Map.-augmentPathMap :: MonadThrow m => [FilePath] -> Map Text Text+augmentPathMap :: MonadThrow m => [Path Abs Dir] -> Map Text Text                                -> m (Map Text Text) augmentPathMap dirs origEnv =   do path <- augmentPath dirs mpath
src/System/Process/Run.hs view
@@ -14,6 +14,7 @@     ,callProcess     ,callProcess'     ,callProcessInheritStderrStdout+    ,callProcessObserveStdout     ,createProcess'     ,ProcessExitedUnsuccessfully     ,Cmd(..)@@ -42,7 +43,7 @@ data Cmd = Cmd   { cmdDirectoryToRunIn :: Maybe (Path Abs Dir) -- ^ directory to run in   , cmdCommandToRun :: FilePath -- ^ command to run-  , cmdEnvOverride::EnvOverride+  , cmdEnvOverride :: EnvOverride   , cmdCommandLineArguments :: [String] -- ^ command line arguments   } @@ -84,7 +85,7 @@  -- | Like 'System.Process.callProcess', but takes an optional working directory and -- environment override, and throws 'ProcessExitedUnsuccessfully' if the--- process exits unsuccessfully.+-- process exits unsuccessfully and a 'ReadProcessException' if the executable is not found. -- -- Inherits stdout and stderr. callProcess :: (MonadIO m, MonadLogger m) => Cmd -> m ()@@ -92,7 +93,7 @@  -- | Like 'System.Process.callProcess', but takes an optional working directory and -- environment override, and throws 'ProcessExitedUnsuccessfully' if the--- process exits unsuccessfully.+-- process exits unsuccessfully and a 'ReadProcessException' if the executable is not found. -- -- Inherits stdout and stderr. callProcess' :: (MonadIO m, MonadLogger m)@@ -112,6 +113,20 @@     let inheritOutput cp = cp { std_in = CreatePipe, std_out = Inherit, std_err = Inherit }     callProcess' inheritOutput cmd +callProcessObserveStdout :: (MonadIO m, MonadLogger m) => Cmd -> m String+callProcessObserveStdout cmd = do+    c <- liftM modCP (cmdToCreateProcess cmd)+    $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)+  where+    modCP c = c { std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit }+ -- | Like 'System.Process.Internal.createProcess_', but taking a 'Cmd'. -- Note that the 'Handle's provided by 'UseHandle' are not closed -- automatically.@@ -125,6 +140,7 @@     $logCreateProcess c     liftIO $ System.Process.createProcess_ tag c +-- Throws a 'ReadProcessException' if process is not found. cmdToCreateProcess :: MonadIO m => Cmd -> m CreateProcess cmdToCreateProcess (Cmd wd cmd0 menv args) = do     cmd <- preProcess wd menv cmd0
+ src/Text/PrettyPrint/Leijen/Extended.hs view
@@ -0,0 +1,314 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+-- | This module re-exports some of the interface for+-- "Text.PrettyPrint.Annotated.Leijen" along with additional definitions+-- useful for stack.+--+-- It defines a 'Monoid' instance for 'Doc'.+module Text.PrettyPrint.Leijen.Extended+  (+  -- * Pretty-print typeclass+  Display(..),++  -- * Ansi terminal Doc+  --+  -- See "System.Console.ANSI" for 'SGR' values to use beyond the colors+  -- provided.+  AnsiDoc, AnsiAnn(..), HasAnsiAnn(..),+  hDisplayAnsi, displayAnsi, displayPlain, renderDefault,++  -- ** Color combinators+  black, red, green, yellow, blue, magenta, cyan, white,+  dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite,+  onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite,+  ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite,++  -- ** Intensity combinators+  bold, faint, normal,++  -- * Selective re-exports from "Text.PrettyPrint.Annotated.Leijen"+  --+  -- Documentation of omissions up-to-date with @annotated-wl-pprint-0.7.0@++  -- ** Documents, parametrized by their annotations+  --+  -- Omitted compared to original: @putDoc, hPutDoc@+  Doc,++  -- ** Basic combinators+  --+  -- Omitted compared to original: @empty, char, text, (<>)@+  --+  -- Instead of @text@ and @char@, use 'fromString'.+  --+  -- Instead of @empty@, use 'mempty'.+  nest, line, linebreak, group, softline, softbreak,++  -- ** Alignment+  --+  -- The combinators in this section can not be described by Wadler's+  -- original combinators. They align their output relative to the+  -- current output position - in contrast to @nest@ which always+  -- aligns to the current nesting level. This deprives these+  -- combinators from being \`optimal\'. In practice however they+  -- prove to be very useful. The combinators in this section should+  -- be used with care, since they are more expensive than the other+  -- combinators. For example, @align@ shouldn't be used to pretty+  -- print all top-level declarations of a language, but using @hang@+  -- for let expressions is fine.+  --+  -- Omitted compared to original: @list, tupled, semiBraces@+  align, hang, indent, encloseSep,++  -- ** Operators+  --+  -- Omitted compared to original: @(<$>), (</>), (<$$>), (<//>)@+  (<+>),++  -- ** List combinators+  hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate,++  -- ** Fillers+  fill, fillBreak,++  -- ** Bracketing combinators+  enclose, squotes, dquotes, parens, angles, braces, brackets,++  -- ** Character documents+  -- Entirely omitted:+  --+  -- @+  -- lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket,+  -- squote, dquote, semi, colon, comma, space, dot, backslash, equals,+  -- pipe+  -- @++  -- ** Primitive type documents+  -- Entirely omitted:+  --+  -- @+  -- string, int, integer, float, double, rational, bool,+  -- @++  -- ** Semantic annotations+  annotate, noAnnotate,++  -- ** Rendering+  -- Original entirely omitted:+  -- @+  -- SimpleDoc(..), renderPretty, renderCompact, displayDecorated, displayDecoratedA, display, displayS, displayIO,+  -- SpanList(..), displaySpans+  -- @++  -- ** Undocumented+  -- Entirely omitted:+  -- @+  -- column, nesting, width+  -- @+  ) where++import Control.Monad.Reader+import Data.Either (partitionEithers)+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 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)++-- TODO: consider smashing together the code for wl-annotated-pprint and+-- wl-pprint-text. The code here already handles doing the+-- ansi-wl-pprint stuff (better!) atop wl-annotated-pprint. So the+-- result would be a package unifying 3 different wl inspired packages.+--+-- Perhaps it can still have native string support, by adding a type+-- parameter to Doc?++instance Monoid (Doc a) where+    mappend = (P.<>)+    mempty = empty++--------------------------------------------------------------------------------+-- Pretty-Print class++class Display a where+    type Ann a+    type Ann a = AnsiAnn+    display :: a -> Doc (Ann a)+    default display :: Show a => a -> Doc (Ann a)+    display = fromString . show++instance Display (Doc a) where+    type Ann (Doc a) = a+    display = id+++--------------------------------------------------------------------------------+-- Ansi Doc++type AnsiDoc = Doc AnsiAnn++newtype AnsiAnn = AnsiAnn [SGR]+    deriving (Eq, Ord, Show, Monoid)++class HasAnsiAnn a where+    getAnsiAnn :: a -> AnsiAnn+    toAnsiDoc :: Doc a -> AnsiDoc+    toAnsiDoc = fmap getAnsiAnn++instance HasAnsiAnn AnsiAnn where+    getAnsiAnn = id+    toAnsiDoc = id++instance HasAnsiAnn () where+    getAnsiAnn _ = mempty++displayPlain :: Display a => a -> T.Text+displayPlain = LT.toStrict . displayAnsiSimple . renderDefault . fmap (\_ -> 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++displayAnsi :: (Display a, HasAnsiAnn (Ann a)) => a -> T.Text+displayAnsi = LT.toStrict . displayAnsiSimple . renderDefault . toAnsiDoc . display++hDisplayAnsi+    :: (Display a, HasAnsiAnn (Ann a), MonadIO m)+    => Handle -> a -> m ()+hDisplayAnsi h x = liftIO $ do+    useAnsi <- hSupportsANSI h+    T.hPutStr h $ if useAnsi then displayAnsi x else displayPlain x++displayAnsiSimple :: SimpleDoc AnsiAnn -> LT.Text+displayAnsiSimple doc =+     LTB.toLazyText $ flip runReader mempty $ displayDecoratedWrap go doc+  where+    go (AnsiAnn sgrs) inner = do+        old <- ask+        let sgrs' = mapMaybe (\sgr -> if sgr == Reset then Nothing else Just (getSGRTag sgr, sgr)) sgrs+            new = if Reset `elem` sgrs+                      then M.fromList sgrs'+                      else foldl (\mp (tag, sgr) -> M.insert tag sgr mp) old sgrs'+        (extra, contents) <- local (\_ -> new) inner+        return (extra, transitionCodes old new <> contents <> transitionCodes new old)+    transitionCodes old new =+        case (null removals, null additions) of+            (True, True) -> mempty+            (True, False) -> fromString (setSGRCode additions)+            (False, _) -> fromString (setSGRCode (Reset : M.elems new))+      where+        (removals, additions) = partitionEithers $ M.elems $+            M.mergeWithKey+               (\_ o n -> if o == n then Nothing else Just (Right n))+               (fmap Left)+               (fmap Right)+               old+               new++displayDecoratedWrap+    :: forall a m. Monad m+    => (forall b. a -> m (b, LTB.Builder) -> m (b, LTB.Builder))+    -> SimpleDoc a+    -> m LTB.Builder+displayDecoratedWrap f doc = do+    (mafter, result) <- go doc+    case mafter of+      Just _ -> fail "Invariant violated by input to displayDecoratedWrap: no matching SAnnotStart for SAnnotStop."+      Nothing -> return result+  where+    spaces n = LTB.fromText (T.replicate n " ")++    go :: SimpleDoc a -> m (Maybe (SimpleDoc a), LTB.Builder)+    go SEmpty = return (Nothing, mempty)+    go (SChar c x) = liftM (fmap (LTB.singleton c <>)) (go x)+    -- NOTE: Could actually use the length to guess at an initial+    -- allocation.  Better yet would be to just use Text in pprint..+    go (SText _l s x) = liftM (fmap (fromString s <>)) (go x)+    go (SLine n x) = liftM (fmap ((LTB.singleton '\n' <>) . (spaces n <>))) (go x)+    go (SAnnotStart ann x) = do+        (mafter, contents) <- f ann (go x)+        case mafter of+            Just after -> liftM (fmap (contents <>)) (go after)+            Nothing -> error "Invariant violated by input to displayDecoratedWrap: no matching SAnnotStop for SAnnotStart."+    go (SAnnotStop x) = return (Just x, mempty)++-- Foreground color combinators++black, red, green, yellow, blue, magenta, cyan, white,+    dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite,+    onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite,+    ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite+    :: Doc AnsiAnn -> Doc AnsiAnn+(black, dullblack, onblack, ondullblack) = colorFunctions Black+(red, dullred, onred, ondullred) = colorFunctions Red+(green, dullgreen, ongreen, ondullgreen) = colorFunctions Green+(yellow, dullyellow, onyellow, ondullyellow) = colorFunctions Yellow+(blue, dullblue, onblue, ondullblue) = colorFunctions Blue+(magenta, dullmagenta, onmagenta, ondullmagenta) = colorFunctions Magenta+(cyan, dullcyan, oncyan, ondullcyan) = colorFunctions Cyan+(white, dullwhite, onwhite, ondullwhite) = colorFunctions White++type EndoAnsiDoc = Doc AnsiAnn -> Doc AnsiAnn++colorFunctions :: Color -> (EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc)+colorFunctions color =+    ( ansiAnn [SetColor Foreground Vivid color]+    , ansiAnn [SetColor Foreground Dull color]+    , ansiAnn [SetColor Background Vivid color]+    , ansiAnn [SetColor Background Dull color]+    )++ansiAnn :: [SGR] -> Doc AnsiAnn -> Doc AnsiAnn+ansiAnn = annotate . AnsiAnn++-- Intensity combinators++bold, faint, normal :: Doc AnsiAnn -> Doc AnsiAnn+bold = ansiAnn [SetConsoleIntensity BoldIntensity]+faint = ansiAnn [SetConsoleIntensity FaintIntensity]+normal = ansiAnn [SetConsoleIntensity NormalIntensity]++-- | Tags for each field of state in SGR (Select Graphics Rendition).+--+-- It's a bit of a hack that 'TagReset' is included.+data SGRTag+    = TagReset+    | TagConsoleIntensity+    | TagItalicized+    | TagUnderlining+    | TagBlinkSpeed+    | TagVisible+    | TagSwapForegroundBackground+    | TagColorForeground+    | TagColorBackground+    deriving (Eq, Ord)++getSGRTag :: SGR -> SGRTag+getSGRTag Reset{}                       = TagReset+getSGRTag SetConsoleIntensity{}         = TagConsoleIntensity+getSGRTag SetItalicized{}               = TagItalicized+getSGRTag SetUnderlining{}              = TagUnderlining+getSGRTag SetBlinkSpeed{}               = TagBlinkSpeed+getSGRTag SetVisible{}                  = TagVisible+getSGRTag SetSwapForegroundBackground{} = TagSwapForegroundBackground+getSGRTag (SetColor Foreground _ _)     = TagColorForeground+getSGRTag (SetColor Background _ _)     = TagColorBackground
src/main/Main.hs view
@@ -1,40 +1,39 @@+{-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}  -- | Main stack tool entry point.  module Main (main) where +#ifndef HIDE_DEP_VERSIONS+import qualified Build_stack+#endif import           Control.Exception-import qualified Control.Exception.Lifted as EL import           Control.Monad hiding (mapM, forM) import           Control.Monad.IO.Class import           Control.Monad.Logger import           Control.Monad.Reader (ask, asks,local,runReaderT)-import           Control.Monad.Trans.Control (MonadBaseControl)+import           Control.Monad.Trans.Either (EitherT)+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 import           Data.List import qualified Data.Map as Map-import qualified Data.Map.Strict as M import           Data.Maybe-import           Data.Maybe.Extra (mapMaybeA) import           Data.Monoid-import qualified Data.Set as Set import           Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.IO 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@@ -42,18 +41,15 @@ import           Distribution.Text (display) import           GHC.IO.Encoding (mkTextEncoding, textEncodingName) import           Lens.Micro-import           Network.HTTP.Client import           Options.Applicative-import           Options.Applicative.Args import           Options.Applicative.Help (errorHelp, stringChunk, vcatChunks) import           Options.Applicative.Builder.Extra import           Options.Applicative.Complicated #ifdef USE_GIT_INFO import           Options.Applicative.Simple (simpleVersion) #endif-import           Options.Applicative.Types (readerAsk, ParserHelp(..))+import           Options.Applicative.Types (ParserHelp(..)) import           Path-import           Path.Extra (toFilePathNoTrailingSep) import           Path.IO import qualified Paths_stack as Meta import           Prelude hiding (pi, mapM)@@ -66,34 +62,36 @@ import qualified Stack.Docker as Docker import           Stack.Dot import           Stack.Exec+import           Stack.GhcPkg (findGhcPkgField) import qualified Stack.Nix as Nix import           Stack.Fetch import           Stack.FileWatch-import           Stack.GhcPkg (getGlobalDB, mkGhcPackagePath) import           Stack.Ghci-import           Stack.Ide+import           Stack.Hoogle+import qualified Stack.IDE as IDE import qualified Stack.Image as Image import           Stack.Init import           Stack.New import           Stack.Options-import           Stack.Package (findOrGenerateCabalFile) import qualified Stack.PackageIndex+import qualified Stack.Path+import           Stack.Runners import           Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball')-import           Stack.Setup+import           Stack.SetupCmd import qualified Stack.Sig as Sig import           Stack.Solver (solveExtraDeps)-import           Stack.Types+import           Stack.Types.Version+import           Stack.Types.Config+import           Stack.Types.Compiler import           Stack.Types.Internal import           Stack.Types.StackT import           Stack.Upgrade import qualified Stack.Upload as Upload import qualified System.Directory as D-import           System.Environment (getEnvironment, getProgName, getArgs, withArgs)+import           System.Environment (getProgName, getArgs, withArgs) import           System.Exit-import           System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock)-import           System.FilePath (pathSeparator, searchPathSeparator)+import           System.FilePath (pathSeparator) import           System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..), hPutStrLn, Handle, hGetEncoding, hSetEncoding)-import           System.Process.Read  -- | Change the character encoding of the given Handle to transliterate -- on unsupported characters instead of throwing an exception@@ -116,15 +114,22 @@     , [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) &&                                           commitCount /= ("UNKNOWN" :: String)]     , [" ", display buildArch]-    , [" hpack-", VERSION_hpack]+    , [depsString]     ]-    where commitCount = $gitCommitCount+  where+    commitCount = $gitCommitCount #else versionString' =     showVersion Meta.version     ++ ' ' : display buildArch-    ++ " hpack" ++ VERSION_hpack+    ++ depsString+  where #endif+#ifdef HIDE_DEP_VERSIONS+    depsString = (" hpack-" ++ VERSION_hpack)+#else+    depsString = ("\nCompiled with:\n" ++ unlines (map ("- " ++) Build_stack.deps))+#endif  main :: IO () main = do@@ -155,9 +160,11 @@       let global = globalOptsFromMonoid isTerminal globalMonoid       when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString'       case globalReExecVersion global of-          Just expectVersion-              | expectVersion /= showVersion Meta.version ->-                  throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)+          Just expectVersion -> do+              expectVersion' <- parseVersionFromString expectVersion+              if checkVersion MatchMinor expectVersion' (fromCabalVersion Meta.version)+                  then return ()+                  else throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)           _ -> return ()       run global `catch` \e ->           -- This special handler stops "stack: " from being printed before the@@ -184,6 +191,9 @@   VERSION_hpack   "stack - The Haskell Tool Stack"   ""+  ("stack's documentation is available at https://docs.haskellstack.org/en/v" <>+   showVersion Meta.version <>+   "/README/")   (globalOpts OuterGlobalOpts)   (Just failureCallback)   addCommands@@ -255,13 +265,7 @@         addCommand' "path"                     "Print out handy path information"                     pathCmd-                    (mapMaybeA-                        (\(desc,name,_) ->-                             flag Nothing-                                  (Just name)-                                  (long (T.unpack name) <>-                                   help desc))-                        paths)+                    Stack.Path.pathParser         addCommand' "unpack"                     "Unpack one or more packages locally"                     unpackCmd@@ -309,25 +313,37 @@                     "Visualize your project's dependency graph using Graphviz dot"                     dotCmd                     dotOptsParser-        addCommand' "exec"-                    "Execute a command"-                    execCmd-                    (execOptsParser Nothing)         addCommand' "ghc"                     "Run ghc"                     execCmd                     (execOptsParser $ Just ExecGhc)-        addCommand' "ghci"-                    "Run ghci in the context of package(s) (experimental)"-                    ghciCmd-                    ghciOptsParser-        addCommand' "repl"-                    "Run ghci in the context of package(s) (experimental) (alias for 'ghci')"-                    ghciCmd-                    ghciOptsParser+        addCommand' "hoogle"+                    "Run hoogle in the context of the current Stack config"+                    hoogleCmd+                    ((,,) <$> many (strArgument (metavar "ARG"))+                          <*> boolFlags+                                  True+                                  "setup"+                                  "If needed: Install hoogle, build haddocks, generate a hoogle database"+                                  idm+                          <*> switch+                                  (long "rebuild" <>+                                   help "Rebuild the hoogle database"))         ) -      -- These two are the only commands allowed in interpreter mode as well+      -- These are the only commands allowed in interpreter mode as well+      addCommand' "exec"+                  "Execute a command"+                  execCmd+                  (execOptsParser Nothing)+      addCommand' "ghci"+                  "Run ghci in the context of package(s) (experimental)"+                  ghciCmd+                  ghciOptsParser+      addCommand' "repl"+                  "Run ghci in the context of package(s) (experimental) (alias for 'ghci')"+                  ghciCmd+                  ghciOptsParser       addCommand' "runghc"                   "Run runghc"                   execCmd@@ -363,28 +379,15 @@             "ide"             "IDE-specific commands"             (do addCommand'-                    "start"-                    "Start the ide-backend service"-                    ideCmd-                    ((,) <$> many (textArgument-                                      (metavar "TARGET" <>-                                       help ("If none specified, use all " <>-                                             "packages defined in current directory")))-                          <*> argsOption (long "ghc-options" <>-                                        metavar "OPTION" <>-                                        help "Additional options passed to GHCi" <>-                                        value []))-                addCommand'                     "packages"                     "List all available local loadable packages"-                    packagesCmd+                    idePackagesCmd                     (pure ())                 addCommand'-                    "load-targets"-                    "List all load targets for a package target"-                    targetsCmd-                    (textArgument-                        (metavar "TARGET")))+                    "targets"+                    "List all available stack targets"+                    ideTargetsCmd+                    (pure ()))         addSubCommands'           Docker.dockerCmdName           "Subcommands specific to Docker use"@@ -439,16 +442,23 @@                     <> help "Do not check package for common mistakes")          -- addCommand hiding global options+        addCommand' :: String -> String -> (a -> GlobalOpts -> IO ()) -> Parser a+                    -> AddCommand         addCommand' cmd title constr =             addCommand cmd title globalFooter constr (globalOpts OtherCmdGlobalOpts) +        addSubCommands' :: String -> String -> AddCommand+                        -> AddCommand         addSubCommands' cmd title =             addSubCommands cmd title globalFooter (globalOpts OtherCmdGlobalOpts)          -- Additional helper that hides global options and shows build options+        addBuildCommand' :: String -> String -> (a -> GlobalOpts -> IO ()) -> Parser a+                         -> AddCommand         addBuildCommand' cmd title constr =             addCommand cmd title globalFooter constr (globalOpts BuildCmdGlobalOpts) +    globalOpts :: GlobalOptsContext -> Parser GlobalOptsMonoid     globalOpts kind =         extraHelpOption hide progName (Docker.dockerCmdName ++ "*") Docker.dockerHelpOptName <*>         extraHelpOption hide progName (Nix.nixCmdName ++ "*") Nix.nixHelpOptName <*>@@ -459,6 +469,9 @@      globalFooter = "Run 'stack --help' for global options that apply to all subcommands." +type AddCommand =+    EitherT (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 -- failing with "Invalid argument `something'")@@ -494,18 +507,32 @@   -> ParserFailure ParserHelp   -> IO (GlobalOptsMonoid, (GlobalOpts -> IO (), t)) interpreterHandler args f = do-  isFile <- D.doesFileExist file-  if isFile-  then runInterpreterCommand file-  else parseResultHandler (errorCombine (noSuchFile file))+  -- args can include top-level config such as --extra-lib-dirs=... (set by+  -- nix-shell) - we need to find the first argument which is a file, everything+  -- afterwards is an argument to the script, everything before is an argument+  -- to Stack+  (stackArgs, fileArgs) <- spanM (fmap not . D.doesFileExist) args+  case fileArgs of+    (file:fileArgs') -> runInterpreterCommand file stackArgs fileArgs'+    [] -> parseResultHandler (errorCombine (noSuchFile firstArg))   where-    file = head args+    firstArg = head args -    -- if the filename contains a path separator then we know that it is not a-    -- command it is a file to be interpreted. In that case we only show the+    spanM _ [] = return ([], [])+    spanM p xs@(x:xs') = do+      r <- p x+      if r+      then do+        (ys, zs) <- spanM p xs'+        return (x:ys, zs)+      else+        return ([], xs)++    -- if the first argument contains a path separator then it might be a file,+    -- or a Stack option referencing a file. In that case we only show the     -- interpreter error message and exclude the command related error messages.     errorCombine =-      if elem pathSeparator file+      if elem pathSeparator firstArg       then overrideErrorHelp       else vcatErrorHelp @@ -516,231 +543,32 @@     noSuchFile name = errorHelp $ stringChunk       ("File does not exist or is not a regular file `" ++ name ++ "'") -    runInterpreterCommand path = do+    runInterpreterCommand path stackArgs fileArgs = do       progName <- getProgName       iargs <- getInterpreterArgs path       let parseCmdLine = commandLineHandler progName True-      let cmdArgs = iargs ++ "--" : args+          separator = if "--" `elem` iargs then [] else ["--"]+          cmdArgs = stackArgs ++ iargs ++ separator ++ path : fileArgs        -- TODO show the command in verbose mode        -- hPutStrLn stderr $ unwords $        --   ["Running", "[" ++ progName, unwords cmdArgs ++ "]"]       (a,b) <- withArgs cmdArgs parseCmdLine       return (a,(b,mempty)) --- | Print out useful path information in a human-readable format (and--- support others later). pathCmd :: [Text] -> GlobalOpts -> IO ()-pathCmd keys go =-    withBuildConfig-        go-        (do env <- ask-            let cfg = envConfig env-                bc = envConfigBuildConfig cfg-            -- This is the modified 'bin-path',-            -- including the local GHC or MSYS if not configured to operate on-            -- global GHC.-            -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'.-            -- So it's not the *minimal* override path.-            menv <- getMinimalEnvOverride-            snap <- packageDatabaseDeps-            plocal <- packageDatabaseLocal-            extra <- packageDatabaseExtra-            global <- getGlobalDB menv =<< getWhichCompiler-            snaproot <- installationRootDeps-            localroot <- installationRootLocal-            distDir <- distRelativeDir-            hpcDir <- hpcReportDir-            compiler <- getCompilerPath =<< getWhichCompiler-            let deprecated = filter ((`elem` keys) . fst) deprecatedPathKeys-            liftIO $ forM_ deprecated $ \(oldOption, newOption) -> T.hPutStrLn stderr $ T.unlines-                [ ""-                , "'--" <> oldOption <> "' will be removed in a future release."-                , "Please use '--" <> newOption <> "' instead."-                , ""-                ]-            forM_-                -- filter the chosen paths in flags (keys),-                -- or show all of them if no specific paths chosen.-                (filter-                     (\(_,key,_) ->-                           (null keys && key /= T.pack deprecatedStackRootOptionName) || elem key keys)-                     paths)-                (\(_,key,path) ->-                      liftIO $ T.putStrLn-                          -- If a single path type is requested, output it directly.-                          -- Otherwise, name all the paths.-                          ((if length keys == 1-                               then ""-                               else key <> ": ") <>-                           path-                               (PathInfo-                                    bc-                                    menv-                                    snap-                                    plocal-                                    global-                                    snaproot-                                    localroot-                                    distDir-                                    hpcDir-                                    extra-                                    compiler))))---- | Passed to all the path printers as a source of info.-data PathInfo = PathInfo-    { piBuildConfig  :: BuildConfig-    , piEnvOverride  :: EnvOverride-    , piSnapDb       :: Path Abs Dir-    , piLocalDb      :: Path Abs Dir-    , piGlobalDb     :: Path Abs Dir-    , piSnapRoot     :: Path Abs Dir-    , piLocalRoot    :: Path Abs Dir-    , piDistDir      :: Path Rel Dir-    , piHpcDir       :: Path Abs Dir-    , piExtraDbs     :: [Path Abs Dir]-    , piCompiler     :: Path Abs File-    }---- | The paths of interest to a user. The first tuple string is used--- for a description that the optparse flag uses, and the second--- string as a machine-readable key and also for @--foo@ flags. The user--- can choose a specific path to list like @--stack-root@. But--- really it's mainly for the documentation aspect.------ When printing output we generate @PathInfo@ and pass it to the--- function to generate an appropriate string.  Trailing slashes are--- removed, see #506-paths :: [(String, Text, PathInfo -> Text)]-paths =-    [ ( "Global stack root directory"-      , T.pack stackRootOptionName-      , T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig )-    , ( "Project root (derived from stack.yaml file)"-      , "project-root"-      , T.pack . toFilePathNoTrailingSep . bcRoot . piBuildConfig )-    , ( "Configuration location (where the stack.yaml file is)"-      , "config-location"-      , T.pack . toFilePath . bcStackYaml . piBuildConfig )-    , ( "PATH environment variable"-      , "bin-path"-      , T.pack . intercalate [searchPathSeparator] . eoPath . piEnvOverride )-    , ( "Install location for GHC and other core tools"-      , "programs"-      , T.pack . toFilePathNoTrailingSep . configLocalPrograms . bcConfig . piBuildConfig )-    , ( "Compiler binary (e.g. ghc)"-      , "compiler-exe"-      , T.pack . toFilePath . piCompiler )-    , ( "Directory containing the compiler binary (e.g. ghc)"-      , "compiler-bin"-      , T.pack . toFilePathNoTrailingSep . parent . piCompiler )-    , ( "Local bin dir where stack installs executables (e.g. ~/.local/bin)"-      , "local-bin"-      , T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig )-    , ( "Extra include directories"-      , "extra-include-dirs"-      , T.intercalate ", " . Set.elems . configExtraIncludeDirs . bcConfig . piBuildConfig )-    , ( "Extra library directories"-      , "extra-library-dirs"-      , T.intercalate ", " . Set.elems . configExtraLibDirs . bcConfig . piBuildConfig )-    , ( "Snapshot package database"-      , "snapshot-pkg-db"-      , T.pack . toFilePathNoTrailingSep . piSnapDb )-    , ( "Local project package database"-      , "local-pkg-db"-      , T.pack . toFilePathNoTrailingSep . piLocalDb )-    , ( "Global package database"-      , "global-pkg-db"-      , T.pack . toFilePathNoTrailingSep . piGlobalDb )-    , ( "GHC_PACKAGE_PATH environment variable"-      , "ghc-package-path"-      , \pi -> mkGhcPackagePath True (piLocalDb pi) (piSnapDb pi) (piExtraDbs pi) (piGlobalDb pi))-    , ( "Snapshot installation root"-      , "snapshot-install-root"-      , T.pack . toFilePathNoTrailingSep . piSnapRoot )-    , ( "Local project installation root"-      , "local-install-root"-      , T.pack . toFilePathNoTrailingSep . piLocalRoot )-    , ( "Snapshot documentation root"-      , "snapshot-doc-root"-      , \pi -> T.pack (toFilePathNoTrailingSep (piSnapRoot pi </> docDirSuffix)))-    , ( "Local project documentation root"-      , "local-doc-root"-      , \pi -> T.pack (toFilePathNoTrailingSep (piLocalRoot pi </> docDirSuffix)))-    , ( "Dist work directory"-      , "dist-dir"-      , T.pack . toFilePathNoTrailingSep . piDistDir )-    , ( "Where HPC reports and tix files are stored"-      , "local-hpc-root"-      , T.pack . toFilePathNoTrailingSep . piHpcDir )-    , ( "DEPRECATED: Use '--local-bin' instead"-      , "local-bin-path"-      , T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig )-    , ( "DEPRECATED: Use '--programs' instead"-      , "ghc-paths"-      , T.pack . toFilePathNoTrailingSep . configLocalPrograms . bcConfig . piBuildConfig )-    , ( "DEPRECATED: Use '--" <> stackRootOptionName <> "' instead"-      , T.pack deprecatedStackRootOptionName-      , T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig )-    ]--deprecatedPathKeys :: [(Text, Text)]-deprecatedPathKeys =-    [ (T.pack deprecatedStackRootOptionName, T.pack stackRootOptionName)-    , ("ghc-paths", "programs")-    , ("local-bin-path", "local-bin")-    ]--data SetupCmdOpts = SetupCmdOpts-    { scoCompilerVersion :: !(Maybe CompilerVersion)-    , scoForceReinstall  :: !Bool-    , scoUpgradeCabal    :: !Bool-    , scoStackSetupYaml  :: !String-    , scoGHCBindistURL   :: !(Maybe String)-    }--setupParser :: Parser SetupCmdOpts-setupParser = SetupCmdOpts-    <$> optional (argument readVersion-            (metavar "GHC_VERSION" <>-             help ("Version of GHC to install, e.g. 7.10.2. " ++-                   "The default is to install the version implied by the resolver.")))-    <*> boolFlags False-            "reinstall"-            "reinstalling GHC, even if available (implies no-system-ghc)"-            idm-    <*> boolFlags False-            "upgrade-cabal"-            "installing the newest version of the Cabal library globally"-            idm-    <*> strOption-            ( long "stack-setup-yaml"-           <> help "Location of the main stack-setup.yaml file"-           <> value defaultStackSetupYaml-           <> showDefault )-    <*> optional (strOption-            (long "ghc-bindist"-           <> metavar "URL"-           <> help "Alternate GHC binary distribution (requires custom --ghc-variant)"))-  where-    readVersion = do-        s <- readerAsk-        case parseCompilerVersion ("ghc-" <> T.pack s) of-            Nothing ->-                case parseCompilerVersion (T.pack s) of-                    Nothing -> readerError $ "Invalid version: " ++ s-                    Just x -> return x-            Just x -> return x+pathCmd keys go = withBuildConfig go (Stack.Path.path keys)  setupCmd :: SetupCmdOpts -> GlobalOpts -> IO ()-setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do+setupCmd sco@SetupCmdOpts{..} go@GlobalOpts{..} = do   (manager,lc) <- loadConfigWithOpts go-  withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk ->-    runStackTGlobal manager (lcConfig lc) go $+  withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do+    let getCompilerVersion = loadCompilerVersion manager go lc+    runStackTGlobal manager (lcConfig lc) go $ do       Docker.reexecWithOptionalContainer           (lcProjectRoot lc)           Nothing           (runStackTGlobal manager (lcConfig lc) go $-           Nix.reexecWithOptionalShell (lcProjectRoot lc) globalResolver globalCompiler $+           Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion $            runStackLoggingTGlobal manager go $ do               (wantedCompiler, compilerCheck, mstack) <-                   case scoCompilerVersion of@@ -752,183 +580,12 @@                                  , Just $ bcStackYaml bc                                  )               miniConfig <- loadMiniConfig manager (lcConfig lc)-              mpaths <- runStackTGlobal manager miniConfig go $-                  ensureCompiler SetupOpts-                  { soptsInstallIfMissing = True-                  , soptsUseSystem =-                    configSystemGHC (lcConfig lc) && not scoForceReinstall-                  , soptsWantedCompiler = wantedCompiler-                  , soptsCompilerCheck = compilerCheck-                  , soptsStackYaml = mstack-                  , soptsForceReinstall = scoForceReinstall-                  , soptsSanityCheck = True-                  , soptsSkipGhcCheck = False-                  , soptsSkipMsys = configSkipMsys $ lcConfig lc-                  , soptsUpgradeCabal = scoUpgradeCabal-                  , soptsResolveMissingGHC = Nothing-                  , soptsStackSetupYaml = scoStackSetupYaml-                  , soptsGHCBindistURL = scoGHCBindistURL-                  }-              let compiler = case wantedCompiler of-                      GhcVersion _ -> "GHC"-                      GhcjsVersion {} -> "GHCJS"-              case mpaths of-                  Nothing -> $logInfo $ "stack will use the " <> compiler <> " on your PATH"-                  Just _ -> $logInfo $ "stack will use a locally installed " <> compiler-              $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"+              runStackTGlobal manager miniConfig go $+                  setup sco wantedCompiler compilerCheck mstack               )           Nothing           (Just $ munlockFile lk) --- | Unlock a lock file, if the value is Just-munlockFile :: MonadIO m => Maybe FileLock -> m ()-munlockFile Nothing = return ()-munlockFile (Just lk) = liftIO $ unlockFile lk---- | Enforce mutual exclusion of every action running via this--- function, on this path, on this users account.------ A lock file is created inside the given directory.  Currently,--- stack uses locks per-snapshot.  In the future, stack may refine--- this to an even more fine-grain locking approach.----withUserFileLock :: (MonadBaseControl IO m, MonadIO m)-                 => GlobalOpts-                 -> Path Abs Dir-                 -> (Maybe FileLock -> m a)-                 -> m a-withUserFileLock go@GlobalOpts{} dir act = do-    env <- liftIO getEnvironment-    let toLock = lookup "STACK_LOCK" env == Just "true"-    if toLock-        then do-            let lockfile = $(mkRelFile "lockfile")-            let pth = dir </> lockfile-            ensureDir dir-            -- Just in case of asynchronous exceptions, we need to be careful-            -- when using tryLockFile here:-            EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive)-                       (maybe (return ()) (liftIO . unlockFile))-                       (\fstTry ->-                        case fstTry of-                          Just lk -> EL.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-                                            when chatter $-                                              liftIO $ hPutStrLn stderr "Lock acquired, proceeding."-                                            act $ Just lk))-        else act Nothing--withConfigAndLock-    :: GlobalOpts-    -> StackT Config IO ()-    -> IO ()-withConfigAndLock go@GlobalOpts{..} inner = do-    (manager, lc) <- loadConfigWithOpts go-    withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk ->-        runStackTGlobal manager (lcConfig lc) go $-            Docker.reexecWithOptionalContainer-                (lcProjectRoot lc)-                Nothing-                (runStackTGlobal manager (lcConfig lc) go inner)-                Nothing-                (Just $ munlockFile lk)---- | Loads global config, ignoring any configuration which would be--- loaded due to $PWD.-withGlobalConfigAndLock-    :: GlobalOpts-    -> StackT Config IO ()-    -> IO ()-withGlobalConfigAndLock go@GlobalOpts{..} inner = do-    manager <- newTLSManager-    lc <- runStackLoggingTGlobal manager go $-        loadConfigMaybeProject globalConfigMonoid Nothing Nothing-    withUserFileLock go (configStackRoot $ lcConfig lc) $ \_lk ->-        runStackTGlobal manager (lcConfig lc) go inner---- For now the non-locking version just unlocks immediately.--- That is, there's still a serialization point.-withBuildConfig-    :: GlobalOpts-    -> StackT EnvConfig IO ()-    -> IO ()-withBuildConfig go inner =-    withBuildConfigAndLock go (\lk -> do munlockFile lk-                                         inner)--withBuildConfigAndLock-    :: GlobalOpts-    -> (Maybe FileLock -> StackT EnvConfig IO ())-    -> IO ()-withBuildConfigAndLock go inner =-    withBuildConfigExt go Nothing inner Nothing--withBuildConfigExt-    :: GlobalOpts-    -> Maybe (StackT Config IO ())-    -- ^ 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 ())-    -- ^ Action that uses the build config.  If Docker is enabled for builds,-    -- this will be run in a Docker container.-    -> Maybe (StackT Config IO ())-    -- ^ 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 go@GlobalOpts{..} mbefore inner mafter = do-    (manager, lc) <- loadConfigWithOpts go--    withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk0 -> do-      -- A local bit of state for communication between callbacks:-      curLk <- newIORef lk0-      let inner' lk =-            -- Locking policy:  This is only used for build commands, which-            -- only need to lock the snapshot, not the global lock.  We-            -- trade in the lock here.-            do dir <- installationRootDeps-               -- Hand-over-hand locking:-               withUserFileLock go dir $ \lk2 -> do-                 liftIO $ writeIORef curLk lk2-                 liftIO $ munlockFile lk-                 inner lk2--      let inner'' lk = do-              bconfig <- runStackLoggingTGlobal manager go $-                  lcLoadBuildConfig lc globalCompiler-              envConfig <--                 runStackTGlobal-                     manager bconfig go-                     (setupEnv Nothing)-              runStackTGlobal-                  manager-                  envConfig-                  go-                  (inner' lk)--      runStackTGlobal manager (lcConfig lc) go $-        Docker.reexecWithOptionalContainer-                 (lcProjectRoot lc)-                 mbefore-                 (runStackTGlobal manager (lcConfig lc) go $-                    Nix.reexecWithOptionalShell (lcProjectRoot lc) globalResolver globalCompiler (inner'' lk0))-                 mafter-                 (Just $ liftIO $-                      do lk' <- readIORef curLk-                         munlockFile lk')- cleanCmd :: CleanOpts -> GlobalOpts -> IO () cleanCmd opts go = withBuildConfigAndLock go (const (clean opts)) @@ -1066,7 +723,8 @@                  (ExecGhc, args) -> return ("ghc", args)                  (ExecRunGhc, args) -> return ("runghc", args)             (manager,lc) <- liftIO $ loadConfigWithOpts go-            withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk ->+            withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do+              let getCompilerVersion = loadCompilerVersion manager go lc               runStackTGlobal manager (lcConfig lc) go $                 Docker.reexecWithOptionalContainer                     (lcProjectRoot lc)@@ -1077,35 +735,48 @@                         menv <- liftIO $ configEnvOverride config plainEnvSettings                         Nix.reexecWithOptionalShell                             (lcProjectRoot lc)-                            globalResolver-                            globalCompiler+                            getCompilerVersion                             (runStackTGlobal manager (lcConfig lc) go $                                 exec menv cmd args))                     Nothing                     Nothing -- Unlocked already above.         ExecOptsEmbellished {..} ->            withBuildConfigAndLock go $ \lk -> do-               config <- asks getConfig-               (cmd, args) <- case (eoCmd, eoArgs) of-                   (ExecCmd cmd, args) -> return (cmd, args)-                   (ExecGhc, args) -> execCompiler "" args-                    -- NOTE: this won't currently work for GHCJS, because it doesn't have-                    -- a runghcjs binary. It probably will someday, though.-                   (ExecRunGhc, args) -> execCompiler "run" args                let targets = concatMap words eoPackages                unless (null targets) $                    Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI                        { boptsCLITargets = map T.pack targets                        }-               munlockFile lk -- Unlock before transferring control away.++               config <- asks getConfig                menv <- liftIO $ configEnvOverride config eoEnvSettings+               (cmd, args) <- case (eoCmd, eoArgs) of+                   (ExecCmd cmd, args) -> return (cmd, args)+                   (ExecGhc, args) -> getGhcCmd "" menv eoPackages args+                    -- NOTE: this won't currently work for GHCJS, because it doesn't have+                    -- a runghcjs binary. It probably will someday, though.+                   (ExecRunGhc, args) ->+                       getGhcCmd "run" menv eoPackages args+               munlockFile lk -- Unlock before transferring control away.                exec menv cmd args   where-    execCompiler cmdPrefix args = do-        wc <- getWhichCompiler-        let cmd = cmdPrefix ++ compilerExeName wc-        return (cmd, args)+      -- return the package-id of the first package in GHC_PACKAGE_PATH+      getPkgId menv wc name = do+          mId <- findGhcPkgField menv wc [] name "id"+          case mId of+              Just i -> return (head $ words (T.unpack i))+              -- should never happen as we have already installed the packages+              _      -> error ("Could not find package id of package " ++ name) +      getPkgOpts menv wc pkgs = do+          ids <- mapM (getPkgId menv wc) pkgs+          return $ map ("-package-id " ++) ids++      getGhcCmd prefix menv pkgs args = do+          wc <- getWhichCompiler+          pkgopts <- getPkgOpts menv wc pkgs+          return (prefix ++ compilerExeName wc, pkgopts ++ args)+ -- | Evaluate some haskell code inline. evalCmd :: EvalOpts -> GlobalOpts -> IO () evalCmd EvalOpts {..} go@GlobalOpts {..} = execCmd execOpts go@@ -1130,36 +801,15 @@     local (set (envEnvConfig.envConfigBuildOpts) boptsLocal)           (ghci ghciOpts) --- | Run ide-backend in the context of a project.-ideCmd :: ([Text], [String]) -> GlobalOpts -> IO ()-ideCmd (targets,args) go@GlobalOpts{..} =-    withBuildConfig go $ -- No locking needed.-      ide targets args- -- | List packages in the project.-packagesCmd :: () -> GlobalOpts -> IO ()-packagesCmd () go@GlobalOpts{..} =-    withBuildConfig go $-      do econfig <- asks getEnvConfig-         locals <--             forM (M.toList (envConfigPackages econfig)) $-             \(dir,_) ->-                  do cabalfp <- findOrGenerateCabalFile dir-                     parsePackageNameFromFilePath cabalfp-         forM_ locals (liftIO . putStrLn . packageNameString)+idePackagesCmd :: () -> GlobalOpts -> IO ()+idePackagesCmd () go =+    withBuildConfig go IDE.listPackages --- | List load targets for a package target.-targetsCmd :: Text -> GlobalOpts -> IO ()-targetsCmd target go@GlobalOpts{..} =-    withBuildConfig go $-    do let boptsCli = defaultBuildOptsCLI { boptsCLITargets = [target] }-       (_realTargets,_,pkgs) <- ghciSetup (ideGhciOpts boptsCli)-       pwd <- getCurrentDir-       targets <--           fmap-               (concat . snd . unzip)-               (mapM (getPackageOptsAndTargetFiles pwd) pkgs)-       forM_ targets (liftIO . putStrLn)+-- | List targets in the project.+ideTargetsCmd :: () -> GlobalOpts -> IO ()+ideTargetsCmd () go =+    withBuildConfig go IDE.listTargets  -- | Pull the current Docker image. dockerPullCmd :: () -> GlobalOpts -> IO ()@@ -1210,36 +860,8 @@                          (const (return ()))                          lk                          defaultBuildOptsCLI-                 Image.stageContainerImageArtifacts mProjectRoot)+                 Image.stageContainerImageArtifacts mProjectRoot images)         (Just $ Image.createContainerImageFromStage mProjectRoot images)---- | Load the configuration with a manager. Convenience function used--- throughout this module.-loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO))-loadConfigWithOpts go@GlobalOpts{..} = do-    manager <- newTLSManager-    mstackYaml <- forM globalStackYaml resolveFile'-    lc <- runStackLoggingTGlobal manager go $ do-        lc <- loadConfig globalConfigMonoid globalResolver mstackYaml-        -- If we have been relaunched in a Docker container, perform in-container initialization-        -- (switch UID, etc.).  We do this after first loading the configuration since it must-        -- happen ASAP but needs a configuration.-        case globalDockerEntrypoint of-            Just de -> Docker.entrypoint (lcConfig lc) de-            Nothing -> return ()-        return lc-    return (manager,lc)--withMiniConfigAndLock-    :: GlobalOpts-    -> StackT MiniConfig IO ()-    -> IO ()-withMiniConfigAndLock go@GlobalOpts{..} inner = do-    manager <- newTLSManager-    miniConfig <- runStackLoggingTGlobal manager go $ do-        lc <- loadConfigMaybeProject globalConfigMonoid globalResolver Nothing-        loadMiniConfig manager (lcConfig lc)-    runStackTGlobal manager miniConfig go inner  -- | Project initialization initCmd :: InitOpts -> GlobalOpts -> IO ()
src/test/Network/HTTP/Download/VerifiedSpec.hs view
@@ -2,7 +2,6 @@ module Network.HTTP.Download.VerifiedSpec where  import Crypto.Hash-import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Logger (LoggingT, runStdoutLoggingT) import Control.Monad.Trans.Reader@@ -12,7 +11,7 @@ import Network.HTTP.Download.Verified import Path import Path.IO-import Test.Hspec hiding (shouldNotBe, shouldNotReturn)+import Test.Hspec  -- TODO: share across test files withTempDir' :: (Path Abs Dir -> IO a) -> IO a@@ -27,7 +26,7 @@ -- | An example DownloadRequest that uses a SHA1 exampleReq :: DownloadRequest exampleReq = fromMaybe (error "exampleReq") $ do-    req <- parseUrl "http://download.fpcomplete.com/stackage-cli/linux64/cabal-install-1.22.4.0.tar.gz"+    let req = parseRequest_ "http://download.fpcomplete.com/stackage-cli/linux64/cabal-install-1.22.4.0.tar.gz"     return DownloadRequest         { drRequest = req         , drHashChecks = [exampleHashCheck]@@ -78,15 +77,6 @@ teardown :: T -> IO () teardown _ = return () -shouldNotBe :: (Show a, Eq a) => a -> a -> Expectation-actual `shouldNotBe` expected =-    unless (actual /= expected) (expectationFailure msg)-  where-    msg = "Value was exactly what it shouldn't be: " ++ show expected--shouldNotReturn :: (Show a, Eq a) => IO a -> a -> Expectation-action `shouldNotReturn` unexpected = action >>= (`shouldNotBe` unexpected)- spec :: Spec spec = beforeAll setup $ afterAll teardown $ do   let exampleProgressHook _ = return ()@@ -143,7 +133,7 @@     -- https://github.com/commercialhaskell/stack/issues/240     it "can download hackage tarballs" $ \T{..} -> withTempDir' $ \dir -> do       dest <- fmap (dir </>) $ parseRelFile "acme-missiles-0.3.tar.gz"-      req <- parseUrl "http://hackage.haskell.org/package/acme-missiles-0.3/acme-missiles-0.3.tar.gz"+      let req = parseRequest_ "http://hackage.haskell.org/package/acme-missiles-0.3/acme-missiles-0.3.tar.gz"       let dReq = DownloadRequest             { drRequest = req             , drHashChecks = []
src/test/Stack/Build/TargetSpec.hs view
@@ -4,7 +4,10 @@  import qualified Data.Text           as T import           Stack.Build.Target-import           Stack.Types+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName+import           Stack.Types.Version+import           Stack.Types.Package import           Test.Hspec  main :: IO ()
src/test/Stack/BuildPlanSpec.hs view
@@ -18,7 +18,11 @@ import System.IO.Temp (withSystemTempDirectory) import Test.Hspec import Stack.Config-import Stack.Types+import Stack.Types.BuildPlan+import Stack.Types.PackageName+import Stack.Types.Version+import Stack.Types.Config+import Stack.Types.Compiler import Stack.Types.StackT  data T = T
src/test/Stack/DotSpec.hs view
@@ -13,7 +13,8 @@ import           Data.Set (Set) import qualified Data.Set as Set import           Data.Text (Text)-import           Stack.Types+import           Stack.Types.PackageName+import           Stack.Types.Version import           Test.Hspec import           Test.Hspec.QuickCheck (prop) import           Test.QuickCheck (forAll,choose,Gen)
+ src/test/Stack/Ghci/PortableFakePaths.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE CPP #-}++-- | Helpers for writing fake paths for test suite for the GhciScript DSL.+-- This must be a separate module because it is used in Teplate Haskell splices.+module Stack.Ghci.PortableFakePaths where++defaultDrive :: FilePath+#ifdef WINDOWS+defaultDrive = "C:\\"+#else+defaultDrive = "/"+#endif
+ src/test/Stack/Ghci/ScriptSpec.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Test suite for the GhciScript DSL+module Stack.Ghci.ScriptSpec where++import           Data.Monoid+import qualified Data.Set as S+import           Distribution.ModuleName+import           Test.Hspec+import qualified System.FilePath as FP+import           Stack.Ghci.PortableFakePaths+import           Path+import           Path.Extra (pathToLazyByteString)++import           Stack.Ghci.Script++spec :: Spec+spec = do+  describe "GHCi" $ do+    describe "Script DSL" $ do++      describe "script" $ do+        it "should seperate commands with a newline" $ do+          let dir = $(mkAbsDir $ defaultDrive FP.</> "src" FP.</> "package-a")+              script = cmdCdGhc dir+                    <> cmdAdd [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 []+          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"])+          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+          scriptToLazyByteString script `shouldBe`+            ":add " <> pathToLazyByteString file <> "\n"++      describe ":cd-ghc" $ do+        it "should render a full absolute path" $ do+          let dir = $(mkAbsDir $ defaultDrive FP.</> "Users" FP.</> "someone" FP.</> "src" FP.</> "project" FP.</> "package-a")+              script = cmdCdGhc dir+          scriptToLazyByteString script `shouldBe`+            ":cd-ghc " <> pathToLazyByteString dir <> "\n"++      describe ":module" $ do+        it "should render empty module as ':module +'" $ do+          let script = cmdModule []+          scriptToLazyByteString script `shouldBe` ":module +\n"++        it "should ensure that a space exists between each module in a module command" $ do+          let script = cmdModule [fromString "Lib.A", fromString "Lib.B"]+          scriptToLazyByteString script `shouldBe` ":module + Lib.A Lib.B\n"
+ src/test/Stack/GhciSpec.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Test suite for GHCi like applications including both GHCi and Intero.+module Stack.GhciSpec where++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 qualified Distribution.ModuleName as ModuleName+import           Stack.Types.Package+import           Stack.Types.PackageName+import           Stack.Types.Version+import           Test.Hspec+import           NeatInterpolation+import           Path+import           Path.Extra (pathToText)+import qualified System.FilePath as FP++import           Stack.Ghci+import           Stack.Ghci.Script (scriptToLazyByteString)+import           Stack.Ghci.PortableFakePaths++textToLazy :: Text -> LBS.ByteString+textToLazy = LBS.fromStrict . T.encodeUtf8++-- | Matches two strings, after converting line-ends in the second to Unix ones+-- (in a hacky way) and converting both to the same type. Workaround for+-- https://github.com/nikita-volkov/neat-interpolation/issues/14.+shouldBeLE :: LBS.ByteString -> Text -> Expectation+shouldBeLE actual expected = shouldBe actual (textToLazy $ T.filter (/= '\r') expected)++baseProjDir, projDirA, projDirB :: Path Abs Dir+baseProjDir = $(mkAbsDir $ defaultDrive FP.</> "Users" FP.</> "someone" FP.</> "src")+projDirA = baseProjDir </> $(mkRelDir "project-a")+projDirB = baseProjDir </> $(mkRelDir "project-b")++relFile :: Path Rel File+relFile = $(mkRelFile $ "exe" FP.</> "Main.hs")++absFile :: Path Abs File+absFile = projDirA </> relFile++projDirAT, projDirBT, relFileT, absFileT :: Text+projDirAT = pathToText projDirA+projDirBT = pathToText projDirB+relFileT = pathToText relFile+absFileT = pathToText absFile++spec :: Spec+spec = do+  describe "GHCi" $ do+    describe "Script rendering" $ do+      describe "should render GHCi scripts" $ do+        it "with one library package" $ do+          let res = scriptToLazyByteString $ renderScriptGhci packages_singlePackage Nothing+          res `shouldBeLE` ghciScript_projectWithLib++        it "with one main package" $ do+          let res = scriptToLazyByteString $ renderScriptGhci []+                                                              (Just absFile)+          res `shouldBeLE` ghciScript_projectWithMain++        it "with one library and main package" $ do+          let res = scriptToLazyByteString $ renderScriptGhci packages_singlePackage+                                                              (Just absFile)+          res `shouldBeLE` ghciScript_projectWithLibAndMain++        it "with multiple library packages" $ do+          let res = scriptToLazyByteString $ renderScriptGhci packages_multiplePackages Nothing+          res `shouldBeLE` ghciScript_multipleProjectsWithLib++      describe "should render intero scripts" $ do+        it "with one library package" $ do+          let res = scriptToLazyByteString $ renderScriptIntero packages_singlePackage Nothing+          res `shouldBeLE` interoScript_projectWithLib++        it "with one main package" $ do+          let res = scriptToLazyByteString $ renderScriptIntero packages_singlePackage+                                                              (Just absFile)+          res `shouldBeLE` interoScript_projectWithMain++        it "with one library and main package" $ do+          let res = scriptToLazyByteString $ renderScriptIntero packages_singlePackage+                                                              (Just absFile)+          res `shouldBeLE` interoScript_projectWithLibAndMain++        it "with multiple library packages" $ do+          let res = scriptToLazyByteString $ renderScriptIntero packages_multiplePackages Nothing+          res `shouldBeLE` interoScript_multipleProjectsWithLib++-- Exptected Intero scripts++interoScript_projectWithLib :: Text+interoScript_projectWithLib = [text|+:cd-ghc $projDirAT+:add Lib.A+:module + Lib.A++|]++interoScript_projectWithMain :: Text+interoScript_projectWithMain = [text|+:cd-ghc $projDirAT+:add Lib.A+:cd-ghc $projDirAT+:add $absFileT+:module + Lib.A++|]++interoScript_projectWithLibAndMain :: Text+interoScript_projectWithLibAndMain = [text|+:cd-ghc $projDirAT+:add Lib.A+:cd-ghc $projDirAT+:add $absFileT+:module + Lib.A++|]++interoScript_multipleProjectsWithLib :: Text+interoScript_multipleProjectsWithLib = [text|+:cd-ghc $projDirAT+:add Lib.A+:cd-ghc $projDirBT+:add Lib.B+:module + Lib.A Lib.B++|]++-- Expected GHCi Scripts++ghciScript_projectWithLib :: Text+ghciScript_projectWithLib = [text|+:add Lib.A+:module + Lib.A++|]++ghciScript_projectWithMain :: Text+ghciScript_projectWithMain = [text|+:add $absFileT+:module +++|]++ghciScript_projectWithLibAndMain :: Text+ghciScript_projectWithLibAndMain = [text|+:add Lib.A+:add $absFileT+:module + Lib.A++|]++ghciScript_multipleProjectsWithLib :: Text+ghciScript_multipleProjectsWithLib = [text|+:add Lib.A+:add Lib.B+:module + Lib.A Lib.B++|]++-- Expected Legacy GHCi scripts++ghciLegacyScript_projectWithMain :: Text+ghciLegacyScript_projectWithMain = [text|+:add+:add $absFileT+:module ++|]++ghciLegacyScript_projectWithLibAndMain :: Text+ghciLegacyScript_projectWithLibAndMain = [text|+:add Lib.A+:add $absFileT+:module + Lib.A+|]++ghciLegacyScript_multipleProjectsWithLib :: Text+ghciLegacyScript_multipleProjectsWithLib = [text|+:add Lib.A Lib.B++:module + Lib.A Lib.B+|]++-- Sample GHCi load configs++packages_singlePackage :: [GhciPkgInfo]+packages_singlePackage =+  [ GhciPkgInfo+    { ghciPkgModules = S.fromList [ModuleName.fromString "Lib.A"]+    , ghciPkgDir = projDirA+    , ghciPkgName = $(mkPackageName "package-a")+    , ghciPkgOpts = []+    , ghciPkgModFiles = S.empty+    , ghciPkgCFiles = S.empty+    , ghciPkgMainIs = M.empty+    , ghciPkgPackage =+      Package+      { packageName = $(mkPackageName "package-a")+      , packageVersion = $(mkVersion "0.1.0.0")+      , packageFiles = GetPackageFiles undefined+      , packageDeps = M.empty+      , packageTools = []+      , packageAllDeps = S.empty+      , packageGhcOptions = []+      , packageFlags = M.empty+      , packageDefaultFlags = M.empty+      , packageHasLibrary = True+      , packageTests = M.empty+      , packageBenchmarks = S.empty+      , packageExes = S.empty+      , packageOpts = GetPackageOpts undefined+      , packageHasExposedModules = True+      , packageSimpleType = True+      }+    }+  ]++packages_multiplePackages :: [GhciPkgInfo]+packages_multiplePackages =+  [ GhciPkgInfo+    { ghciPkgModules = S.fromList [ModuleName.fromString "Lib.A"]+    , ghciPkgDir = projDirA+    , ghciPkgName = $(mkPackageName "package-a")+    , ghciPkgOpts = []+    , ghciPkgModFiles = S.empty+    , ghciPkgCFiles = S.empty+    , ghciPkgMainIs = M.empty+    , ghciPkgPackage =+      Package+      { packageName = $(mkPackageName "package-a")+      , packageVersion = $(mkVersion "0.1.0.0")+      , packageFiles = GetPackageFiles undefined+      , packageDeps = M.empty+      , packageTools = []+      , packageAllDeps = S.empty+      , packageGhcOptions = []+      , packageFlags = M.empty+      , packageDefaultFlags = M.empty+      , packageHasLibrary = True+      , packageTests = M.empty+      , packageBenchmarks = S.empty+      , packageExes = S.empty+      , packageOpts = GetPackageOpts undefined+      , packageHasExposedModules = True+      , packageSimpleType = True+      }+    }+  , GhciPkgInfo+    { ghciPkgModules = S.fromList [ModuleName.fromString "Lib.B"]+    , ghciPkgDir = projDirB+    , ghciPkgName = $(mkPackageName "package-b")+    , ghciPkgOpts = []+    , ghciPkgModFiles = S.empty+    , ghciPkgCFiles = S.empty+    , ghciPkgMainIs = M.empty+    , ghciPkgPackage =+      Package+      { packageName = $(mkPackageName "package-b")+      , packageVersion = $(mkVersion "0.1.0.0")+      , packageFiles = GetPackageFiles undefined+      , packageDeps = M.empty+      , packageTools = []+      , packageAllDeps = S.empty+      , packageGhcOptions = []+      , packageFlags = M.empty+      , packageDefaultFlags = M.empty+      , packageHasLibrary = True+      , packageTests = M.empty+      , packageBenchmarks = S.empty+      , packageExes = S.empty+      , packageOpts = GetPackageOpts undefined+      , packageHasExposedModules = True+      , packageSimpleType = True+      }+    }+  ]
src/test/Stack/NixSpec.hs view
@@ -12,8 +12,10 @@ import Stack.Config import Stack.Config.Nix import Stack.Types.Config+import Stack.Types.Compiler import Stack.Types.Nix import Stack.Types.StackT+import Stack.Types.Version import System.Directory import System.Environment import System.IO.Temp (withSystemTempDirectory)@@ -57,8 +59,10 @@       writeFile (toFilePath stackDotYaml) sampleConfig       lc <- loadConfig' manager       (nixEnable $ configNix $ lcConfig lc) `shouldBe` True-    it "sees that the only package asked for is glpk and adds GHC from nixpkgs mirror of LTS resolver" $ \T{..} -> inTempDir $ do-      writeFile (toFilePath stackDotYaml) sampleConfig-      lc <- loadConfig' manager-      (nixPackages $ configNix $ lcConfig lc) `shouldBe` ["glpk"]-      nixCompiler (lcConfig lc) Nothing Nothing `shouldBe` "haskell.packages.lts-2_10.ghc"+    it "sees that the only package asked for is glpk and asks for the correct GHC derivation" $+      \T{..} -> inTempDir $ do+        writeFile (toFilePath stackDotYaml) sampleConfig+        lc <- loadConfig' manager+        (nixPackages $ configNix $ lcConfig lc) `shouldBe` ["glpk"]+        v <- parseVersion "7.10.3"+        nixCompiler (GhcVersion v) `shouldBe` "haskell.compiler.ghc7103"
src/test/Stack/PackageDumpSpec.hs view
@@ -9,7 +9,11 @@ import           Data.Conduit.Text (decodeUtf8) import Control.Monad.Trans.Resource (runResourceT) import Stack.PackageDump-import Stack.Types+import Stack.Types.GhcPkgId+import Stack.Types.PackageIdentifier+import Stack.Types.PackageName+import Stack.Types.Version+import Stack.Types.Compiler import Test.Hspec import Test.Hspec.QuickCheck import System.Process.Read
+ src/test/Stack/SolverSpec.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Test suite for "Stack.Solver"+module Stack.SolverSpec where++import           Data.Text (unpack)+import           Stack.Types.FlagName+import           Stack.Types.PackageName+import           Stack.Types.Version+import           Test.Hspec+import qualified Data.Map as Map++import Stack.Solver++spec :: Spec+spec =+  describe "Stack.Solver" $ do+    successfulExample +      "text-1.2.1.1 (latest: 1.2.2.0) -integer-simple (via: parsec-3.1.9) (new package)"+      $(mkPackageName "text")+      $(mkVersion "1.2.1.1")+      [ ($(mkFlagName "integer-simple"), False)+      ]+    successfulExample +      "hspec-snap-1.0.0.0 *test (via: servant-snap-0.5) (new package)"+      $(mkPackageName "hspec-snap")+      $(mkVersion "1.0.0.0")+      []+    successfulExample+      "time-locale-compat-0.1.1.1 -old-locale (via: http-api-data-0.2.2) (new package)"+      $(mkPackageName "time-locale-compat")+      $(mkVersion "0.1.1.1")+      [ ($(mkFlagName "old-locale"), False)+      ]+    successfulExample+      "flowdock-rest-0.2.0.0 -aeson-compat *test (via: haxl-fxtra-0.0.0.0) (new package)"+      $(mkPackageName "flowdock-rest")+      $(mkVersion "0.2.0.0")+      [ ($(mkFlagName "aeson-compat"), False)+      ]+  where+    successfulExample input pkgName pkgVersion flags =+      it ("parses " ++ unpack input) $ +        parseCabalOutputLine input `shouldBe` Right (pkgName, (pkgVersion, Map.fromList flags))
+ src/test/Stack/StoreSpec.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -fno-warn-orphans -Wwarn #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+module Stack.StoreSpec where++import           Control.Applicative+import qualified Data.ByteString as BS+import           Data.Containers (mapFromList, setFromList)+import           Data.Int+import           Data.Map (Map)+import           Data.Sequences (fromList)+import           Data.Set (Set)+import           Data.Store.TH+import           Data.Text (Text)+import qualified Data.Vector.Unboxed as UV+import           Data.Word+import           Language.Haskell.TH+import           Language.Haskell.TH.ReifyMany+import           Prelude+import           Stack.Types.Build+import           Stack.Types.BuildPlan+import           Stack.Types.PackageDump+import           Stack.Types.PackageIndex+import           Test.Hspec+import           Test.SmallCheck.Series++-- NOTE: these were copied from Data.Store. Should probably be moved to+-- smallcheck.++instance (Monad m, Serial m k, Serial m a, Ord k) => Serial m (Map k a) where+    series = fmap mapFromList series++instance Monad m => Serial m Text where+    series = fmap fromList series++instance (Monad m, Serial m a, UV.Unbox a) => Serial m (UV.Vector a) where+    series = fmap fromList series++instance Monad m => Serial m BS.ByteString where+    series = fmap BS.pack series++instance (Monad m, Serial m a, Ord a) => Serial m (Set a) where+    series = fmap setFromList series++addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a]+addMinAndMaxBounds xs =+    (if (minBound :: a) `notElem` xs then [minBound] else []) +++    (if (maxBound :: a) `notElem` xs && (maxBound :: a) /= minBound then maxBound : xs else xs)++$(do let ns = [ ''Int64, ''Word64, ''Word, ''Word8+              ]+         f n = [d| instance Monad m => Serial m $(conT n) where+                      series = generate (\_ -> addMinAndMaxBounds [0, 1]) |]+     concat <$> mapM f ns)++$(do let tys = [ ''InstalledCacheInner+               , ''PackageCacheMap+               , ''MiniBuildPlan+               , ''BuildCache+               , ''ConfigCache+               ]+     ns <- reifyManyWithoutInstances ''Serial tys (`notElem` [''UV.Vector])+     let f n = [d| instance Monad m => Serial m $(conT n) |]+     concat <$> mapM f ns)++verbose :: Bool+verbose = False++spec :: Spec+spec = do+    describe "Roundtrips binary formats" $ do+        $(smallcheckManyStore False 6+            [ [t| InstalledCacheInner |]+            , [t| PackageCacheMap |]+            , [t| BuildCache |]+            ])+        -- Blows up with > 5+        $(smallcheckManyStore False 5+            [ [t| MiniBuildPlan |]+            ])+        -- Blows up with > 4+        $(smallcheckManyStore False 4+            [ [t| ConfigCache |]+            ])
+ src/test/Stack/Untar/UntarSpec.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Stack.Untar.UntarSpec where++import Data.List (sort)+import Path+import Path.IO (removeDirRecur)+import qualified System.FilePath as FP+import Stack.Fetch (untar)+import Test.Hspec++spec :: Spec+spec = do+    describe "Untarring ignores strange entries" $+      mapM_ testTarFile tarFiles+  where+    -- XXX tests are run in the project root folder, but data files are next to+    -- this source data.+    currentFolder = $(mkRelDir $ "src" FP.</> "test" FP.</> "Stack" FP.</> "Untar")++    -- Pairs test tarball names + list of unexpected entries contained: for each+    -- entry, a tar pathname + description.+    tarFilesBase = [ ("test1", [])+                   , ("test2", [ ("bar", "named pipe")+                               , ("devB", "block device")+                               , ("devC", "character device")])]+    -- Prepend tarball name to tar pathnames:+    tarFiles =+      [ (name,+         [ (name FP.</> entryName, d)+         | (entryName, d) <- entries])+      | (name, entries) <- tarFilesBase ]++    testTarFile (name, expected) =+      it ("works on test " ++ name) $+        getEntries name `shouldReturn` sort expected++    getEntries name = do+      tarballName <- parseRelFile $ name ++ ".tar.gz"+      expectedTarFolder <- parseRelDir name++      entries <- untar (currentFolder </> tarballName) expectedTarFolder currentFolder+      removeDirRecur $ currentFolder </> expectedTarFolder+      return $ sort entries
stack.cabal view
@@ -1,7 +1,7 @@ name: stack-version: 1.1.2+version: 1.2.0 cabal-version: >=1.10-build-type: Simple+build-type: Custom license: BSD3 license-file: LICENSE maintainer: manny@fpcomplete.com@@ -47,6 +47,12 @@     default: False     manual: True +flag hide-dependency-versions+    description:+        Hides dependency versions from "stack --version", used only by building with stack.yaml+    default: False+    manual: True+ library          if os(windows)@@ -62,10 +68,11 @@         Data.Attoparsec.Args         Data.Attoparsec.Combinators         Data.Attoparsec.Interpreter-        Data.Binary.VersionTagged         Data.IORef.RunOnce         Data.Maybe.Extra         Data.Monoid.Extra+        Data.Store.VersionTagged+        Data.Yaml.Extra         Distribution.Version.Extra         Network.HTTP.Download         Network.HTTP.Download.Verified@@ -101,7 +108,9 @@         Stack.FileWatch         Stack.GhcPkg         Stack.Ghci-        Stack.Ide+        Stack.Ghci.Script+        Stack.Hoogle+        Stack.IDE         Stack.Image         Stack.Init         Stack.New@@ -110,14 +119,17 @@         Stack.Package         Stack.PackageDump         Stack.PackageIndex+        Stack.Path+        Stack.PrettyPrint+        Stack.Runners         Stack.SDist         Stack.Setup         Stack.Setup.Installed+        Stack.SetupCmd         Stack.Sig         Stack.Sig.GPG         Stack.Sig.Sign         Stack.Solver-        Stack.Types         Stack.Types.Build         Stack.Types.BuildPlan         Stack.Types.Urls@@ -131,6 +143,7 @@         Stack.Types.Internal         Stack.Types.Nix         Stack.Types.Package+        Stack.Types.PackageDump         Stack.Types.PackageIdentifier         Stack.Types.PackageIndex         Stack.Types.PackageName@@ -140,6 +153,7 @@         Stack.Types.Version         Stack.Upgrade         Stack.Upload+        Text.PrettyPrint.Leijen.Extended         System.Process.Log         System.Process.PagerEditor         System.Process.Read@@ -154,11 +168,12 @@         base-compat >=0.6 && <0.10,         base16-bytestring >=0.1.1.6 && <0.2,         base64-bytestring >=1.0.0.1 && <1.1,-        binary ==0.7.*,+        binary >=0.7 && <0.9,         binary-tagged >=0.1.1 && <0.2,         blaze-builder >=0.4.0.2 && <0.5,         byteable >=0.1.1 && <0.2,-        bytestring >=0.10.6.0 && <0.11,+        bytestring >=0.10.4.0 && <0.11,+        clock >=0.7.2 && <0.8,         conduit >=1.2.4 && <1.3,         conduit-extra >=1.1.7.1 && <1.2,         containers >=0.5.5.1 && <0.6,@@ -170,34 +185,35 @@         enclosed-exceptions >=1.0.1.1 && <1.1,         errors >=2.1.2 && <2.2,         exceptions >=0.8.0.2 && <0.9,-        extra >=1.4.6 && <1.5,+        extra >=1.4.7 && <1.6,         fast-logger >=2.3.1 && <2.5,         filelock >=0.1.0.1 && <0.2,         filepath >=1.3.0.2 && <1.5,         fsnotify >=0.2.1 && <0.3,-        generic-deriving >=1.9.0 && <1.10,+        generic-deriving >=1.10.4.1 && <1.12,         hashable >=1.2.3.2 && <1.3,         hit >=0.6.3 && <0.7,         hpc >=0.6.0.2 && <0.7,-        http-client >=0.4.17 && <0.5,-        http-client-tls >=0.2.2 && <0.3,-        http-conduit >=2.1.7 && <2.2,+        http-client >=0.5.0 && <0.6,+        http-client-tls >=0.3.0 && <0.4,+        http-conduit >=2.2.0 && <2.3,         http-types >=0.8.6 && <0.10,-        lifted-base >=0.2.3.6 && <0.3,+        lifted-async >=0.9.0 && <0.10,+        lifted-base ==0.2.3.6.* || >0.2.3.7 && <0.3,         microlens >=0.3.0.0 && <0.5,         monad-control >=1.0.1.0 && <1.1,         monad-logger >=0.3.13.1 && <0.4,-        monad-unlift >=0.1.2.0 && <0.2,+        monad-unlift >=0.2.0 && <0.3,         mtl >=2.1.3.1 && <2.3,         open-browser >=0.2.1 && <0.3,-        optparse-applicative >=0.11 && <0.13,-        path >=0.5.1 && <0.6,+        optparse-applicative ==0.13.*,+        path >=0.5.8 && <0.6,         path-io >=1.1.0 && <2.0.0,-        persistent >=2.1.2 && <2.6,-        persistent-sqlite >=2.1.4 && <2.6,+        persistent >=2.1.2 && <2.7,+        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 && <1.2,-        process >=1.2.0.0 && <1.3,+        process >=1.2.1.0 && <1.5,         regex-applicative-text >=0.1.0.1 && <0.2,         resourcet >=1.1.4.1 && <1.2,         retry >=0.6 && <0.8,@@ -206,15 +222,16 @@         split >=0.2.3.1 && <0.3,         stm >=2.4.4 && <2.5,         streaming-commons >=0.1.10.0 && <0.2,-        tar >=0.4.1.0 && <0.6,-        template-haskell >=2.9.0.0 && <2.11,+        tar >=0.5.0.3 && <0.6,+        template-haskell >=2.9.0.0 && <2.12,         temporary >=1.2.0.3 && <1.3,         text >=1.2.0.4 && <1.3,         text-binary >=0.2.1 && <0.3,-        time >=1.4.2 && <1.6,+        time >=1.4.2 && <1.7,         tls >=1.3.8 && <1.4,-        transformers >=0.3.0.0 && <0.5,+        transformers >=0.3.0.0 && <0.6,         transformers-base >=0.4.4 && <0.5,+        unicode-transforms ==0.1.*,         unix-compat >=0.4.1.4 && <0.5,         unordered-containers >=0.2.5.1 && <0.3,         vector >=0.10.12.3 && <0.12,@@ -224,11 +241,13 @@         deepseq ==1.4.*,         hastache >=0.6.1 && <0.7,         project-template ==0.2.*,-        zip-archive >=0.2.3.7 && <0.3,-        hpack >=0.14.0 && <0.15+        zip-archive >=0.2.3.7 && <0.4,+        hpack >=0.14.0 && <0.16,+        store >=0.2.1.0 && <0.3,+        annotated-wl-pprint >=0.7.0 && <0.8     default-language: Haskell2010     hs-source-dirs: src/-    ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+    ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-identities  executable stack     @@ -245,27 +264,32 @@             gitrev >=1.1 && <1.3,             optparse-simple >=0.0.3 && <0.1         cpp-options: -DUSE_GIT_INFO+    +    if flag(hide-dependency-versions)+        cpp-options: -DHIDE_DEP_VERSIONS     main-is: Main.hs     build-depends:         Cabal >=1.18.1.5 && <1.25,         base >=4.7 && <5,         bytestring >=0.10.4.0 && <0.11,         containers >=0.5.5.1 && <0.6,-        directory >=1.2.2.0 && <1.3,+        directory >=1.2.1.0 && <1.3,+        either >=4.4.1.1 && <4.5,         filelock >=0.1.0.1 && <0.2,-        filepath >=1.4.0.0 && <1.5,-        http-client >=0.4.28 && <0.5,-        lifted-base >=0.2.3.6 && <0.3,+        filepath >=1.3.0.2 && <1.5,+        hpack >=0.14.0 && <0.16,+        http-client >=0.5.0 && <0.6,+        lifted-base ==0.2.3.6.* || >0.2.3.7 && <0.3,         microlens >=0.3.0.0 && <0.5,         monad-control >=1.0.1.0 && <1.1,         monad-logger >=0.3.13.1 && <0.4,         mtl >=2.1.3.1 && <2.3,-        optparse-applicative >=0.11.0.2 && <0.13,-        path >=0.5.7 && <0.6,+        optparse-applicative ==0.13.*,+        path >=0.5.8 && <0.6,         path-io >=1.1.0 && <2.0.0,-        stack >=1.1.2 && <1.2,+        stack >=1.2.0 && <1.3,         text >=1.2.0.4 && <1.3,-        transformers >=0.4.2.0 && <0.5+        transformers >=0.3.0.0 && <0.6     default-language: Haskell2010     hs-source-dirs: src/main     other-modules:@@ -273,30 +297,42 @@     ghc-options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates  test-suite stack-test+    +    if os(windows)+        cpp-options: -DWINDOWS     type: exitcode-stdio-1.0     main-is: Test.hs     build-depends:         Cabal >=1.18.1.5 && <1.25,-        QuickCheck >=2.8.1 && <2.9,+        QuickCheck >=2.8.2 && <2.10,         attoparsec >=0.13.0.2 && <0.14,         base >=4.7 && <5,         conduit >=1.2.6.6 && <1.3,         conduit-extra >=1.1.13.1 && <1.2,         containers >=0.5.5.1 && <0.6,-        cryptohash >=0.11.6 && <0.12,-        directory >=1.2.2.0 && <1.3,+        cryptohash >=0.11.9 && <0.12,+        directory >=1.2.1.0 && <1.3,         exceptions >=0.8.2.1 && <0.9,-        hspec >=2.2.3 && <2.3,-        http-conduit >=2.1.10.1 && <2.2,+        filepath >=1.4.0.0 && <1.5,+        hspec ==2.2.*,+        http-conduit >=2.2.0 && <2.3,         monad-logger >=0.3.18 && <0.4,+        neat-interpolation ==0.3.*,         path >=0.5.7 && <0.6,         path-io >=1.1.0 && <2.0.0,         resourcet >=1.1.7.4 && <1.2,         retry >=0.6 && <0.8,-        stack >=1.1.2 && <1.2,+        stack >=1.2.0 && <1.3,         temporary >=1.2.0.4 && <1.3,         text >=1.2.2.1 && <1.3,-        transformers >=0.4.2.0 && <0.5+        transformers >=0.3.0.0 && <0.6,+        mono-traversable >=0.10.2 && <0.11,+        th-reify-many >=0.1.6 && <0.2,+        smallcheck >=1.1.1 && <1.2,+        bytestring >=0.10.6.0 && <0.11,+        store >=0.2.1.0 && <0.3,+        vector >=0.11.0.0 && <0.12,+        template-haskell >=2.10.0.0 && <2.11     default-language: Haskell2010     hs-source-dirs: src/test     other-modules:@@ -306,10 +342,16 @@         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 test-suite stack-integration-test     @@ -320,18 +362,18 @@     build-depends:         async >=2.1.0 && <2.2,         base >=4.7 && <5,-        bytestring >=0.10.6.0 && <0.11,+        bytestring >=0.10.4.0 && <0.11,         conduit >=1.2.6.6 && <1.3,         conduit-extra >=1.1.13.1 && <1.2,         containers >=0.5.5.1 && <0.6,-        directory >=1.2.2.0 && <1.3,-        filepath >=1.4.0.0 && <1.5,-        hspec >=2.2.3 && <2.3,-        process >=1.2.3.0 && <1.3,+        directory >=1.2.1.0 && <1.3,+        filepath >=1.3.0.2 && <1.5,+        hspec ==2.2.*,+        process >=1.2.0.0 && <1.5,         resourcet >=1.1.7.4 && <1.2,         temporary >=1.2.0.4 && <1.3,         text >=1.2.2.1 && <1.3,-        transformers >=0.4.2.0 && <0.5,+        transformers >=0.3.0.0 && <0.6,         unix-compat >=0.4.1.4 && <0.5     default-language: Haskell2010     hs-source-dirs: test/integration test/integration/lib
stack.yaml view
@@ -1,4 +1,4 @@-resolver: lts-5.17+resolver: lts-6.0 # docker: #   enable: true #   repo: fpco/stack-full@@ -12,7 +12,17 @@   packages:     - zlib extra-deps:-- hpack-0.14.0-- path-io-1.1.0-- th-lift-instances-0.1.6-- aeson-0.11.2.0+- th-lift-instances-0.1.7+- th-utilities-0.2.0.1+- store-0.2.1.2+- store-core-0.2.0.2+- th-orphans-0.13.1+- http-client-0.5.3.1+- http-client-tls-0.3.0+- http-conduit-2.2.0+- path-0.5.8+- unicode-transforms-0.1.0.1+- optparse-applicative-0.13.0.0+flags:+  stack:+    hide-dependency-versions: true
test/integration/lib/StackTest.hs view
@@ -1,11 +1,16 @@ module StackTest where +import Control.Monad+import Control.Monad.IO.Class+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 import System.Process import System.Exit import System.Info (os)@@ -42,6 +47,65 @@         then error "stack was supposed to fail, but didn't"         else return () +type Repl = ReaderT ReplConnection IO++data ReplConnection+  = ReplConnection+    { replStdin  :: Handle+    , replStdout :: Handle+    }++nextPrompt :: Repl ()+nextPrompt = do+    (ReplConnection _ handle) <- ask+    c <- liftIO $ hGetChar handle+    if c == '>'+      then do _ <- liftIO $ hGetChar handle+              return ()+      else nextPrompt++replCommand :: String -> Repl ()+replCommand cmd = do+    (ReplConnection input _) <- ask+    liftIO $ hPutStrLn input cmd++replGetLine :: Repl String+replGetLine = (fmap replStdout ask) >>= liftIO . hGetLine++replGetChar :: Repl Char+replGetChar = (fmap replStdout ask) >>= liftIO . hGetChar++runRepl :: FilePath -> [String] -> ReaderT ReplConnection IO () -> IO ExitCode+runRepl cmd args actions = do+    logInfo $ "Running: " ++ cmd ++ " " ++ intercalate " " (map showProcessArgDebug args)+    (Just rStdin, Just rStdout, Just rStderr, ph) <-+        createProcess (proc cmd args)+        { std_in = CreatePipe+        , std_out = CreatePipe+        , std_err = CreatePipe+        }+    hSetBuffering rStdin NoBuffering+    hSetBuffering rStdout NoBuffering+    hSetBuffering rStderr NoBuffering++    forkIO $ bracket (openFile "/tmp/stderr" WriteMode) hClose+        $ \err -> forever $ catch (hGetChar rStderr >>= hPutChar err)+                  $ \e -> if isEOFError e then return () else throw e++    runReaderT (nextPrompt >> actions) (ReplConnection rStdin rStdout)+    waitForProcess ph++repl :: [String] -> Repl () -> IO ()+repl args action = do+    stack <- getEnv "STACK_EXE"+    ec <- runRepl stack ("repl":args) action+    if ec == ExitSuccess+        then return ()+        else return ()+        -- TODO: Understand why the exit code is 1 despite running GHCi tests+        -- successfully.+        -- else error $ "Exited with exit code: " ++ show ec+ -- | Run stack with arguments and apply a check to the resulting -- stderr output if the process succeeded. stackCheckStderr :: [String] -> (String -> IO ()) -> IO ()@@ -122,11 +186,8 @@ -- | Is the OS Windows? isWindows = os == "mingw32" --- | Is the OS Mac OS X?-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@.-defaultResolverArg = "--resolver=lts-5"+defaultResolverArg = "--resolver=lts-6.0"