packages feed

stack 1.0.2 → 1.0.4

raw patch · 46 files changed

+1545/−1209 lines, 46 filesdep +hpackdep +path-iodep +zip-archivedep −bifunctorsdep −conduit-combinatorsdep −file-embeddep ~aesondep ~asyncdep ~bytestring

Dependencies added: hpack, path-io, zip-archive

Dependencies removed: bifunctors, conduit-combinators, file-embed, monad-loops, old-locale, void, word8

Dependency ranges changed: aeson, async, bytestring, conduit, errors, exceptions, extra, filepath, hashable, hspec, http-client, http-conduit, monad-logger, optparse-applicative, process, split, stack, temporary

Files

CONTRIBUTING.md view
@@ -2,6 +2,8 @@  ## Bug Reports +Before reporting a bug, please ensure that you are using the latest release (currently stack-1.0.4).  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]@@ -48,7 +50,9 @@ The documentation is rendered on [haskellstack.org](http://haskellstack.org) by readthedocs.org using Sphinx and CommonMark. Since links and formatting vary from GFM, please check the documentation there before submitting a PR to fix-those.+those.  In particular, links to other documentation files intentionally have+`.html` extensions instead of `.md`, unfortunately (see+[#1506](https://github.com/commercialhaskell/stack/issues/1506) for details).  If your changes move or rename files, or subsume Wiki content, please continue to leave a file/page in the old location temporarily, in addition to the new location. This will allow users time to update any shared links to the old location. Please also update any links in other files, or on the Wiki, to point to the new file location.
ChangeLog.md view
@@ -1,5 +1,76 @@ # Changelog +## 1.0.4++Major changes:++* Some notable changes in `stack init`:+    * Overall it should now be able to initialize almost all existing cabal+      packages out of the box as long as the package itself is consistently+      defined.+    * Choose the best possible snapshot and add extra dependencies on top+      of a snapshot resolver rather than a compiler resolver -+      [#1583](https://github.com/commercialhaskell/stack/pull/1583)+    * Automatically omit a package (`--omit-packages`) when it is compiler+      incompatible or when there are packages with conflicting dependency+      requirements - [#1674](https://github.com/commercialhaskell/stack/pull/1674).+    * Some more changes for a better user experience. Please refer to+      the doc guide for details.+* Add support for hpack, alternative package description format+  [#1679](https://github.com/commercialhaskell/stack/issues/1679)++Other enhancements:++* Docker: pass ~/.ssh and SSH auth socket into container, so that git repos+  work [#1358](https://github.com/commercialhaskell/stack/issues/1358).+* Docker: strip suffix from docker --version.+  [#1653](https://github.com/commercialhaskell/stack/issues/1653)+* Docker: pass USER and PWD environment bariables into container.+* On each run, stack will test the stack root directory (~/.stack), and the+  project and package work directories (.stack-work) for whether they are+  owned by the current user and abort if they are not. This precaution can+  be disabled with the `--allow-different-user` flag or `allow-different-user`+  option in the global config (~/.stack/config.yaml).+  [#471](https://github.com/commercialhaskell/stack/issues/471)+* Added `stack clean --full` option for full working dir cleanup.+* YAML config: support Zip archives.+* Redownload build plan if parsing fails+  [#1702](https://github.com/commercialhaskell/stack/issues/1702).+* Give mustache templates access to a 'year' tag+  [#1716](https://github.com/commercialhaskell/stack/pull/1716).+* Have "stack ghci" warn about module name aliasing.+* Add "stack ghci --load-local-deps".+* Build Setup.hs with -rtsopts+  [#1687](https://github.com/commercialhaskell/stack/issues/1687).+* `stack init` accepts a list of directories.+* Add flag infos to DependencyPlanFailures (for better error output in case of+  flags) [#713](https://github.com/commercialhaskell/stack/issues/713)+* `stack new --bare` complains for overwrites, and add `--force` option+  [#1597](https://github.com/commercialhaskell/stack/issues/1597).++Bug fixes:++* Previously, `stack ghci` would fail with `cannot satisfy -package-id` when the+  implicit build step changes the package key of some dependency.+* Fix: Building with ghcjs: "ghc-pkg: Prelude.chr: bad argument: 2980338"+  [#1665](https://github.com/commercialhaskell/stack/issues/1665).+* Fix running test / bench with `--profile` / `--trace`.+* Fix: build progress counter is no longer visible+  [#1685](https://github.com/commercialhaskell/stack/issues/1685).+* Use "-RTS" w/ profiling to allow extra args+  [#1772](https://github.com/commercialhaskell/stack/issues/1772).+* Fix withUnpackedTarball7z to find name of srcDir after unpacking+  (fixes `stack setup` fails for ghcjs project on windows)+  [#1774](https://github.com/commercialhaskell/stack/issues/1774).+* Add space before auto-generated bench opts (makes profiling options work+  uniformly for applications and benchmark suites)+  [#1771](https://github.com/commercialhaskell/stack/issues/1771).+* Don't try to find plugin if it resembles flag.+* Setup.hs changes cause package dirtiness+  [#1711](https://github.com/commercialhaskell/stack/issues/1711).+* Send "stack templates" output to stdout+  [#1792](https://github.com/commercialhaskell/stack/issues/1792).+ ## 1.0.2  Release notes:@@ -7,7 +78,7 @@ - Arch Linux: Stack has been adopted into the   [official community repository](https://www.archlinux.org/packages/community/x86_64/stack/),   so we will no longer be updating the AUR with new versions. See the-  [install/upgrade guide](http://docs.haskellstack.org/en/stable/install_and_upgrade.html#arch-linux)+  [install/upgrade guide](http://docs.haskellstack.org/en/stable/install_and_upgrade/#arch-linux)   for current download instructions.  Major changes:@@ -20,9 +91,9 @@ - Disable locale/codepage hacks when GHC >=7.10.3   [#1552](https://github.com/commercialhaskell/stack/issues/1552) - Specify multiple images to build for `stack image container`-  [docs](http://docs.haskellstack.org/en/v1.0.2/yaml_configuration.html#image)+  [docs](http://docs.haskellstack.org/en/stable/yaml_configuration/#image) - Specify which executables to include in images for `stack image container`-  [docs](http://docs.haskellstack.org/en/v1.0.2/yaml_configuration.html#image)+  [docs](http://docs.haskellstack.org/en/stable/yaml_configuration/#image) - Docker: pass supplemantary groups and umask into container - If git fetch fails wipe the directory and try again from scratch   [#1418](https://github.com/commercialhaskell/stack/issues/1418)@@ -142,16 +213,16 @@   source code, so please check the links on the website before submitting a PR   to fix them. * The locations of the-  [Ubuntu](http://docs.haskellstack.org/en/stable/install_and_upgrade.html#ubuntu)+  [Ubuntu](http://docs.haskellstack.org/en/stable/install_and_upgrade/#ubuntu)   and-  [Debian](http://docs.haskellstack.org/en/stable/install_and_upgrade.html#debian)+  [Debian](http://docs.haskellstack.org/en/stable/install_and_upgrade/#debian)   package repositories have changed to have correct URL semantics according to   Debian's guidelines   [#1378](https://github.com/commercialhaskell/stack/issues/1378). The old   locations will continue to work for some months, but we suggest that you   adjust your `/etc/apt/sources.list.d/fpco.list` to the new location to avoid   future disruption.-* [openSUSE and SUSE Linux Enterprise](http://docs.haskellstack.org/en/stable/install_and_upgrade.html#opensuse-suse-linux-enterprise)+* [openSUSE and SUSE Linux Enterprise](http://docs.haskellstack.org/en/stable/install_and_upgrade/#opensuse-suse-linux-enterprise)   packages are now available, thanks to [@mimi1vx](https://github.com/mimi1vx).   Note: there will be some lag before these pick up new versions, as they are   based on Stackage LTS.@@ -206,7 +277,7 @@  * GHCJS can now be used with stackage snapshots via the new `compiler` field. * Windows installers are now available:-  [download them here](http://docs.haskellstack.org/en/stable/install_and_upgrade.html#windows)+  [download them here](http://docs.haskellstack.org/en/stable/install_and_upgrade/#windows)   [#613](https://github.com/commercialhaskell/stack/issues/613) * Docker integration works with non-FPComplete generated images   [#531](https://github.com/commercialhaskell/stack/issues/531)@@ -420,7 +491,7 @@ * Respect TemplateHaskell addDependentFile dependency changes ([#105](https://github.com/commercialhaskell/stack/issues/105))     * TH dependent files are taken into account when determining whether a package needs to be built. * Overhauled target parsing, added `--test` and `--bench` options [#651](https://github.com/commercialhaskell/stack/issues/651)-    * For details, see [Build commands documentation](http://docs.haskellstack.org/en/stable/build_command.html)+    * For details, see [Build commands documentation](http://docs.haskellstack.org/en/stable/build_command/)  Other enhancements:
src/Data/Binary/VersionTagged.hs view
@@ -29,7 +29,7 @@ import Data.Typeable (Typeable) import Control.Exception.Enclosed (tryAnyDeep) import Path-import Path.IO (createTree)+import Path.IO (ensureDir) import qualified Data.Text as T  type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a)@@ -40,7 +40,7 @@                  -> a                  -> m () taggedEncodeFile fp x = liftIO $ do-    createTree (parent fp)+    ensureDir (parent fp)     BinaryTagged.taggedEncodeFile (toFilePath fp) x  -- | Read from the given file. If the read fails, run the given action and
src/Path/Find.hs view
@@ -5,7 +5,8 @@ module Path.Find   (findFileUp   ,findDirUp-  ,findFiles)+  ,findFiles+  ,findInParents)   where  import Control.Monad@@ -14,7 +15,7 @@ import System.IO.Error (isPermissionError) import Data.List import Path-import Path.IO+import Path.IO hiding (findFiles)  -- | Find the location of a file matching the given predicate. findFileUp :: (MonadIO m,MonadThrow m)@@ -41,7 +42,7 @@            -> Maybe (Path Abs Dir)             -- ^ Do not ascend above this directory.            -> m (Maybe (Path Abs t))           -- ^ Absolute path. findPathUp pathType dir p upperBound =-  do entries <- listDirectory dir+  do entries <- listDir dir      case find p (pathType entries) of        Just path -> return (Just path)        Nothing | Just dir == upperBound -> return Nothing@@ -57,7 +58,7 @@   do (dirs,files) <- catchJust (\ e -> if isPermissionError e                                          then Just ()                                          else Nothing)-                               (listDirectory dir)+                               (listDir dir)                                (\ _ -> return ([], []))      subResults <-        forM dirs@@ -66,3 +67,16 @@                   then findFiles entry p traversep                   else return [])      return (concat (filter p files : subResults))++-- | @findInParents f path@ applies @f@ to @path@ and its 'parent's until+-- it finds a 'Just' or reaches the root directory.+findInParents :: MonadIO m => (Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a)+findInParents f path = do+    mres <- f path+    case mres of+        Just res -> return (Just res)+        Nothing -> do+            let next = parent path+            if next == path+                then return Nothing+                else findInParents f next
− src/Path/IO.hs 
@@ -1,265 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}---- | IO actions that might be put in a package at some point.--module Path.IO-  (getWorkingDir-  ,parseRelAsAbsDir-  ,parseRelAsAbsFile-  ,listDirectory-  ,resolveDir-  ,resolveFile-  ,resolveDirMaybe-  ,resolveFileMaybe-  ,ResolveException(..)-  ,removeFile-  ,removeFileIfExists-  ,removeTree-  ,removeTreeIfExists-  ,renameFile-  ,renameFileIfExists-  ,renameDir-  ,renameDirIfExists-  ,moveFile-  ,moveFileIfExists-  ,moveDir-  ,moveDirIfExists-  ,fileExists-  ,dirExists-  ,copyFile-  ,copyFileIfExists-  ,copyDirectoryRecursive-  ,createTree-  ,withCanonicalizedSystemTempDirectory-  ,withCanonicalizedTempDirectory)-  where--import           Control.Exception hiding (catch)-import           Control.Monad-import           Control.Monad.Catch-import           Control.Monad.IO.Class-import           Data.Either-import           Data.Maybe.Extra-import           Data.Typeable-import           Path-import qualified System.Directory as D-import qualified System.FilePath as FP-import           System.IO.Error-import           System.IO.Temp--data ResolveException-    = ResolveDirFailed (Path Abs Dir) FilePath FilePath-    | ResolveFileFailed (Path Abs Dir) FilePath FilePath-    deriving Typeable-instance Exception ResolveException--instance Show ResolveException where-    show (ResolveDirFailed _ _ z) = "Could not resolve directory " ++ z-    show (ResolveFileFailed _ _ z) = "Could not resolve file " ++ z---- | Get the current working directory.-getWorkingDir :: (MonadIO m) => m (Path Abs Dir)-getWorkingDir = liftIO (D.canonicalizePath "." >>= parseAbsDir)---- | Parse a directory path. If it's relative, then the absolute version--- is yielded, based off the working directory.------ NOTE that this only works if the directory exists, but does not--- ensure that it's a directory.-parseRelAsAbsDir :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs Dir)-parseRelAsAbsDir fp = parseAbsDir =<< liftIO (D.canonicalizePath fp)---- | Parse a file path. If it's relative, then the absolute version is--- yielded, based off the working directory.------ NOTE that this only works if the file exists, but does not ensure--- that it's a file.-parseRelAsAbsFile :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs File)-parseRelAsAbsFile fp = parseAbsFile =<< liftIO (D.canonicalizePath fp)---- | Appends a stringly-typed relative path to an absolute path, and then--- canonicalizes it.-resolveDir :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs Dir)-resolveDir x y =-  do result <- resolveDirMaybe x y-     case result of-       Nothing ->-         throwM $ ResolveDirFailed x y fp-         where fp = toFilePath x FP.</> y-       Just fp -> return fp---- | Appends a stringly-typed relative path to an absolute path, and then--- canonicalizes it.-resolveFile :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs File)-resolveFile x y =-  do result <- resolveFileMaybe x y-     case result of-       Nothing ->-         throwM $-         ResolveFileFailed x y fp-         where fp = toFilePath x FP.</> y-       Just fp -> return fp---- Internal helper to define resolveDirMaybe and resolveFileMaybe in one-resolveCheckParse :: (MonadIO m)-                 => (FilePath -> IO Bool) -- check if file/dir does exist-                 -> (FilePath -> m a)     -- parse into absolute file/dir-                 -> Path Abs Dir-                 -> FilePath-                 -> m (Maybe a)-resolveCheckParse check parse x y = do-    let fp = toFilePath x FP.</> y-    exists <- liftIO $ check fp-    if exists-        then do-            canonic <- liftIO $ D.canonicalizePath fp-            liftM Just (parse canonic)-        else return Nothing---- | Appends a stringly-typed relative path to an absolute path, and then--- canonicalizes it. If the path doesn't exist (and therefore cannot--- be canonicalized, 'Nothing' is returned).-resolveDirMaybe :: (MonadIO m,MonadThrow m)-                => Path Abs Dir -> FilePath -> m (Maybe (Path Abs Dir))-resolveDirMaybe = resolveCheckParse D.doesDirectoryExist parseAbsDir---- | Appends a stringly-typed relative path to an absolute path, and then--- canonicalizes it. If the path doesn't exist (and therefore cannot--- be canonicalized, 'Nothing' is returned).-resolveFileMaybe :: (MonadIO m,MonadThrow m)-                 => Path Abs Dir -> FilePath -> m (Maybe (Path Abs File))-resolveFileMaybe = resolveCheckParse D.doesFileExist parseAbsFile---- | List objects in a directory, excluding "@.@" and "@..@".  Entries are not sorted.-listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File])-listDirectory dir =-  do entriesFP <- liftIO (D.getDirectoryContents dirFP)-     entries <--       forMaybeM (map (dirFP ++) entriesFP)-            (\entryFP ->-               do isDir <- liftIO (D.doesDirectoryExist entryFP)-                  if isDir-                     then case parseAbsDir entryFP of-                            Nothing -> return Nothing-                            Just entryDir ->-                              if dir `isParentOf` entryDir-                                 then return (Just (Left entryDir))-                                 else return Nothing-                     else case parseAbsFile entryFP of-                            Nothing -> return Nothing-                            Just entryFile -> return (Just (Right entryFile)))-     return (lefts entries,rights entries)-  where dirFP = toFilePath dir---- | Remove a file. Bails out if it doesn't exist.-removeFile :: MonadIO m => Path b File -> m ()-removeFile = liftIO . D.removeFile . toFilePath---- | Remove a file. Optimistically assumes it exists. If it doesn't,--- doesn't complain.-removeFileIfExists :: MonadIO m => Path b File -> m ()-removeFileIfExists = ignoreDoesNotExist . removeFile---- | Rename a file. Bails out if it doesn't exist.-renameFile :: MonadIO m => Path b1 File -> Path b2 File -> m ()-renameFile from to = liftIO (D.renameFile (toFilePath from) (toFilePath to))---- | Rename a file. Optimistically assumes it exists. If it doesn't,--- doesn't complain.-renameFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m ()-renameFileIfExists from to = ignoreDoesNotExist (renameFile from to)--renameDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()-renameDir from to = liftIO (D.renameDirectory (toFilePath from) (toFilePath to))---- | Rename a directory. Optimistically assumes it exists. If it--- doesn't, doesn't complain.-renameDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()-renameDirIfExists from to = ignoreDoesNotExist (renameDir from to)---- | Make a directory tree, creating parents if needed.-createTree :: MonadIO m => Path b Dir -> m ()-createTree = liftIO . D.createDirectoryIfMissing True . toFilePath---- | Move a file. Bails out if it doesn't exist.-moveFile :: MonadIO m => Path b1 File -> Path b2 Dir -> m ()-moveFile from to = renameFile from (to </> filename from)---- | Move a file. Optimistically assumes it exists. If it doesn't,--- doesn't complain.-moveFileIfExists :: MonadIO m => Path b1 File -> Path b2 Dir -> m ()-moveFileIfExists from to = ignoreDoesNotExist (moveFile from to)---- | Move a dir. Bails out if it doesn't exist.-moveDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()-moveDir from to = renameDir from (to </> dirname from)---- | Move a dir. Optimistically assumes it exists. If it doesn't,--- doesn't complain.-moveDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()-moveDirIfExists from to = ignoreDoesNotExist (moveDir from to)---- | Remove a tree. Bails out if it doesn't exist.-removeTree :: MonadIO m => Path b Dir -> m ()-removeTree = liftIO . D.removeDirectoryRecursive . toFilePath---- | Remove tree, don't complain about non-existent directories.-removeTreeIfExists :: MonadIO m => Path b Dir -> m ()-removeTreeIfExists = ignoreDoesNotExist . removeTree---- | Does the file exist?-fileExists :: MonadIO m => Path b File -> m Bool-fileExists = liftIO . D.doesFileExist . toFilePath---- | Does the directory exist?-dirExists :: MonadIO m => Path b Dir -> m Bool-dirExists = liftIO . D.doesDirectoryExist . toFilePath---- | Copies a file to another path. Bails out if it doesn't exist.-copyFile :: MonadIO m => Path b1 File -> Path b2 File -> m ()-copyFile from to = liftIO (D.copyFile (toFilePath from) (toFilePath to))---- | Copies a file to another path. Optimistically assumes it exists. If--- it doesn't, doesn't complain.-copyFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m ()-copyFileIfExists from to = ignoreDoesNotExist (copyFile from to)---- | Copy a directory recursively.  This just uses 'copyFile', so it is not smart about symbolic--- links or other special files.-copyDirectoryRecursive :: (MonadIO m,MonadThrow m)-                       => Path Abs Dir -- ^ Source directory-                       -> Path Abs Dir -- ^ Destination directory-                       -> m ()-copyDirectoryRecursive srcDir destDir =-    do liftIO (D.createDirectoryIfMissing False (toFilePath destDir))-       (srcSubDirs,srcFiles) <- listDirectory srcDir-       forM_ srcFiles-             (\srcFile ->-                case stripDir srcDir srcFile of-                  Nothing -> return ()-                  Just relFile -> copyFile srcFile (destDir </> relFile))-       forM_ srcSubDirs-             (\srcSubDir ->-                case stripDir srcDir srcSubDir of-                  Nothing -> return ()-                  Just relSubDir -> copyDirectoryRecursive srcSubDir (destDir </> relSubDir))---- Utility function for a common pattern of ignoring does-not-exist errors.-ignoreDoesNotExist :: MonadIO m => IO () -> m ()-ignoreDoesNotExist f =-    liftIO $ catch f $ \e -> unless (isDoesNotExistError e) (throwIO e)--withCanonicalizedSystemTempDirectory :: (MonadMask m, MonadIO m)-    => String                -- ^ Directory name template.-    -> (Path Abs Dir -> m a) -- ^ Callback that can use the canonicalized directory-    -> m a-withCanonicalizedSystemTempDirectory template action =-  withSystemTempDirectory template (parseRelAsAbsDir >=> action)--withCanonicalizedTempDirectory :: (MonadMask m, MonadIO m)-    => FilePath              -- ^ Temp directory to create the directory in-    -> String                -- ^ Directory name template.-    -> (Path Abs Dir -> m a) -- ^ Callback that can use the canonicalized directory-    -> m a-withCanonicalizedTempDirectory targetDir template action =-  withTempDirectory targetDir template (parseRelAsAbsDir >=> action)
src/Stack/Build/Cache.hs view
@@ -26,7 +26,7 @@     ) where  import           Control.Exception.Enclosed (handleIO)-import           Control.Monad.Catch (MonadThrow)+import           Control.Monad.Catch (MonadThrow, MonadCatch) import           Control.Monad.IO.Class import           Control.Monad.Logger (MonadLogger) import           Control.Monad.Reader@@ -59,7 +59,7 @@                  => InstallLocation -> m [PackageIdentifier] getInstalledExes loc = do     dir <- exeInstalledDir loc-    (_, files) <- liftIO $ handleIO (const $ return ([], [])) $ listDirectory dir+    (_, files) <- liftIO $ handleIO (const $ return ([], [])) $ listDir dir     return $ mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files  -- | Mark the given executable as installed@@ -67,7 +67,7 @@                  => InstallLocation -> PackageIdentifier -> m () markExeInstalled loc ident = do     dir <- exeInstalledDir loc-    createTree dir+    ensureDir dir     ident' <- parseRelFile $ packageIdentifierString ident     let fp = toFilePath $ dir </> ident'     -- TODO consideration for the future: list all of the executables@@ -76,12 +76,12 @@     liftIO $ writeFile fp "Installed"  -- | Mark the given executable as not installed-markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)+markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadCatch m)                     => InstallLocation -> PackageIdentifier -> m () markExeNotInstalled loc ident = do     dir <- exeInstalledDir loc     ident' <- parseRelFile $ packageIdentifierString ident-    removeFileIfExists (dir </> ident')+    ignoringAbsence (removeFile $ dir </> ident')  -- | Stored on disk to know whether the flags have changed or any -- files have changed.@@ -145,7 +145,7 @@ writeCabalMod dir = writeCache dir configCabalMod  -- | Delete the caches for the project.-deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m, HasEnvConfig env)+deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadCatch m, HasEnvConfig env)              => Path Abs Dir -> m () deleteCaches dir = do     {- FIXME confirm that this is acceptable to remove@@ -153,7 +153,7 @@     removeFileIfExists bfp     -}     cfp <- configCacheFile dir-    removeFileIfExists cfp+    ignoringAbsence (removeFile cfp)  -- | Write to a cache. writeCache :: (BinarySchema a, MonadIO m)@@ -191,7 +191,7 @@ writeFlagCache gid cache = do     file <- flagCacheFile gid     liftIO $ do-        createTree (parent file)+        ensureDir (parent file)         taggedEncodeFile file cache  -- | Mark a test suite as having succeeded@@ -289,7 +289,7 @@                       -> m () writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do     file <- precompiledCacheFile pkgident copts depIDs-    createTree $ parent file+    ensureDir (parent file)     mlibpath <-         case mghcPkgId of             Executable _ -> return Nothing
src/Stack/Build/ConstructPlan.hs view
@@ -481,9 +481,7 @@     case partitionEithers deps of         ([], pairs) -> return $ Right $ mconcat pairs         (errs, _) -> return $ Left $ DependencyPlanFailures-            (PackageIdentifier-                (packageName package)-                (packageVersion package))+            package             (Map.fromList errs)   where     adrVersion (ADRToInstall task) = packageIdentifierVersion $ taskProvides task
src/Stack/Build/Execute.hs view
@@ -64,12 +64,13 @@ import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path import           Path.Extra (toFilePathNoTrailingSep)-import           Path.IO+import           Path.IO hiding (findExecutable, makeAbsolute) import           Prelude hiding (FilePath, writeFile, any) import           Stack.Build.Cache import           Stack.Build.Haddock import           Stack.Build.Installed import           Stack.Build.Source+import           Stack.Config import           Stack.Constants import           Stack.Coverage import           Stack.Fetch as Fetch@@ -272,6 +273,7 @@                     , toFilePath setupHs                     , "-o"                     , toFilePath tmpOutputPath+                    , "-rtsopts"                     ] ++                     ["-build-runner" | wc == Ghcjs]             runCmd' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args) Nothing@@ -291,7 +293,7 @@                -> (ExecuteEnv -> m a)                -> m a withExecuteEnv menv bopts baseConfigOpts locals globalPackages snapshotPackages localPackages inner = do-    withCanonicalizedSystemTempDirectory stackProgName $ \tmpdir -> do+    withSystemTempDir stackProgName $ \tmpdir -> do         configLock <- newMVar ()         installLock <- newMVar ()         idMap <- liftIO $ newTVarIO Map.empty@@ -347,7 +349,7 @@         snapBin <- (</> bindirSuffix) `liftM` installationRootDeps         localBin <- (</> bindirSuffix) `liftM` installationRootLocal         destDir <- asks $ configLocalBin . getConfig-        createTree destDir+        ensureDir destDir          destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir @@ -364,7 +366,7 @@                     case loc of                         Snap -> snapBin                         Local -> localBin-            mfp <- resolveFileMaybe bindir $ T.unpack name ++ ext+            mfp <- forgivingAbsence (resolveFile bindir $ T.unpack name ++ ext)             case mfp of                 Nothing -> do                     $logWarn $ T.concat@@ -759,7 +761,7 @@         | console = inner Nothing         | otherwise = do             logPath <- buildLogPath package msuffix-            createTree (parent logPath)+            ensureDir (parent logPath)             let fp = toFilePath logPath             bracket                 (liftIO $ openBinaryFile fp WriteMode)@@ -768,6 +770,10 @@      withCabal package pkgDir mlogFile inner = do         config <- asks getConfig++        unless (configAllowDifferentUser config) $+            checkOwnership (pkgDir </> configWorkDir config)+         let envSettings = EnvSettings                 { esIncludeLocals = taskLocation task == Local                 , esIncludeGhcPackagePath = False@@ -882,7 +888,7 @@                     distDir <- distDirFromDir pkgDir                     let setupDir = distDir </> $(mkRelDir "setup")                         outputFile = setupDir </> $(mkRelFile "setup")-                    createTree setupDir+                    ensureDir setupDir                     compilerPath <-                         case compiler of                             Ghc -> getGhcPath@@ -975,6 +981,7 @@             _ -> return Nothing      copyPreCompiled (PrecompiledCache mlib exes) = do+        wc <- getWhichCompiler         announceTask task "using precompiled package"         forM_ mlib $ \libpath -> do             menv <- getMinimalEnvOverride@@ -991,8 +998,9 @@                  -- In case a build of the library with different flags already exists, unregister it                 -- before copying.+                let ghcPkgExe = ghcPkgExeName wc                 catch-                    (readProcessNull Nothing menv' "ghc-pkg"+                    (readProcessNull Nothing menv' ghcPkgExe                         [ "unregister"                         , "--force"                         , packageIdentifierString taskProvides@@ -1001,7 +1009,7 @@                         ReadProcessException{} -> return ()                         _ -> throwM ex) -                readProcessNull Nothing menv' "ghc-pkg"+                readProcessNull Nothing menv' ghcPkgExe                     [ "register"                     , "--force"                     , libpath@@ -1015,7 +1023,6 @@             _ -> return ()          -- Find the package in the database-        wc <- getWhichCompiler         let pkgDbs = [bcoSnapDB eeBaseConfigOpts]          case mlib of@@ -1180,7 +1187,7 @@         when toRun $ do             buildDir <- distDirFromDir pkgDir             hpcDir <- hpcDirFromDir pkgDir-            when needHpc (createTree hpcDir)+            when needHpc (ensureDir hpcDir)              let suitesToRun                   = [ testSuitePair@@ -1203,7 +1210,7 @@                             _ -> ""                 tixPath <- liftM (pkgDir </>) $ parseRelFile $ exeName ++ ".tix"                 exePath <- liftM (buildDir </>) $ parseRelFile $ "build/" ++ testName' ++ "/" ++ exeName-                exists <- fileExists exePath+                exists <- doesFileExist exePath                 menv <- liftIO $    configEnvOverride config EnvSettings                     { esIncludeLocals = taskLocation task == Local                     , esIncludeGhcPackagePath = True@@ -1214,10 +1221,10 @@                     then do                         -- We clear out the .tix files before doing a run.                         when needHpc $ do-                            tixexists <- fileExists tixPath+                            tixexists <- doesFileExist tixPath                             when tixexists $                                 $logWarn ("Removing HPC file " <> T.pack (toFilePath tixPath))-                            removeFileIfExists tixPath+                            ignoringAbsence (removeFile tixPath)                          let args = toAdditionalArgs topts                             argsDisplay = case args of@@ -1248,7 +1255,7 @@                         (Just inH, Nothing, Nothing, ph) <- liftIO $ createProcess_ "singleBuild.runTests" cp                         when isTestTypeLib $ do                             logPath <- buildLogPath package (Just stestName)-                            createTree (parent logPath)+                            ensureDir (parent logPath)                             liftIO $ hPutStr inH $ show (logPath, testName)                         liftIO $ hClose inH                         ec <- liftIO $ waitForProcess ph@@ -1324,7 +1331,7 @@           cabal False ("bench" : args)  -- | Strip Template Haskell "Loading package" lines and making paths absolute.-mungeBuildOutput :: (MonadIO m, MonadThrow m)+mungeBuildOutput :: (MonadIO m, MonadCatch m)                  => Bool -- ^ exclude TH loading?                  -> Bool -- ^ convert paths to absolute?                  -> Path Abs Dir -- ^ package's root directory@@ -1350,7 +1357,7 @@         mabs <-             if isValidSuffix y                 then liftM (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $-                        resolveFileMaybe pkgDir (T.unpack $ T.dropWhile isSpace x)+                        forgivingAbsence (resolveFile pkgDir (T.unpack $ T.dropWhile isSpace x))                 else return Nothing         case mabs of             Nothing -> return bs@@ -1372,11 +1379,11 @@ getSetupHs :: Path Abs Dir -- ^ project directory            -> IO (Path Abs File) getSetupHs dir = do-    exists1 <- fileExists fp1+    exists1 <- doesFileExist fp1     if exists1         then return fp1         else do-            exists2 <- fileExists fp2+            exists2 <- doesFileExist fp2             if exists2                 then return fp2                 else throwM $ NoSetupHsFound dir
src/Stack/Build/Haddock.hs view
@@ -42,7 +42,6 @@ import           Stack.Types.Build import           Stack.PackageDump import           Stack.Types-import           System.Directory               (getModificationTime) import qualified System.FilePath                as FP import           System.IO.Error                (isDoesNotExistError) import           System.Process.Read@@ -152,7 +151,7 @@  -- | Generate Haddock index and contents for specified packages. generateHaddockIndex-    :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)+    :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m)     => Text     -> EnvOverride     -> WhichCompiler@@ -161,10 +160,10 @@     -> Path Abs Dir     -> m () generateHaddockIndex descr envOverride wc dumpPackages docRelFP destDir = do-    createTree destDir+    ensureDir destDir     interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages     unless (null interfaceOpts) $ do-        let destIndexFile = toFilePath (haddockIndexFile destDir)+        let destIndexFile = haddockIndexFile destDir         eindexModTime <- liftIO (tryGetModificationTime destIndexFile)         let needUpdate =                 case eindexModTime of@@ -174,7 +173,7 @@         when needUpdate $ do             $logInfo                 (T.concat ["Updating Haddock index for ", descr, " in\n",-                           T.pack destIndexFile])+                           T.pack (toFilePath destIndexFile)])             liftIO (mapM_ copyPkgDocs interfaceOpts)             readProcessNull                 (Just destDir)@@ -194,7 +193,7 @@                         packageIdentifierString dpPackageIdent FP.</>                         (packageNameString name FP.<.> "haddock")                 destInterfaceAbsFile <- parseCollapsedAbsFile (toFilePath destDir FP.</> destInterfaceRelFP)-                esrcInterfaceModTime <- tryGetModificationTime (toFilePath srcInterfaceAbsFile)+                esrcInterfaceModTime <- tryGetModificationTime srcInterfaceAbsFile                 return $                     case esrcInterfaceModTime of                         Left _ -> Nothing@@ -208,7 +207,7 @@                                 , srcInterfaceModTime                                 , srcInterfaceAbsFile                                 , destInterfaceAbsFile )-    tryGetModificationTime :: FilePath -> IO (Either () UTCTime)+    tryGetModificationTime :: Path Abs File -> IO (Either () UTCTime)     tryGetModificationTime = tryJust (guard . isDoesNotExistError) . getModificationTime     copyPkgDocs :: (a, UTCTime, Path Abs File, Path Abs File) -> IO ()     copyPkgDocs (_,srcInterfaceModTime,srcInterfaceAbsFile,destInterfaceAbsFile) = do@@ -218,7 +217,7 @@         -- aren't reliably supported on Windows, and (2) the filesystem containing dependencies'         -- docs may not be available where viewing the docs (e.g. if building in a Docker         -- container).-        edestInterfaceModTime <- tryGetModificationTime (toFilePath destInterfaceAbsFile)+        edestInterfaceModTime <- tryGetModificationTime destInterfaceAbsFile         case edestInterfaceModTime of             Left _ -> doCopy             Right destInterfaceModTime@@ -226,11 +225,11 @@                 | otherwise -> return ()       where         doCopy = do-            removeTreeIfExists destHtmlAbsDir-            createTree destHtmlAbsDir+            ignoringAbsence (removeDirRecur destHtmlAbsDir)+            ensureDir destHtmlAbsDir             onException-                (copyDirectoryRecursive (parent srcInterfaceAbsFile) destHtmlAbsDir)-                (removeTreeIfExists destHtmlAbsDir)+                (copyDirRecur (parent srcInterfaceAbsFile) destHtmlAbsDir)+                (ignoringAbsence (removeDirRecur destHtmlAbsDir))         destHtmlAbsDir = parent destInterfaceAbsFile  -- | Find first DumpPackage matching the GhcPkgId
src/Stack/Build/Source.hs view
@@ -63,7 +63,7 @@ import           Stack.Package import           Stack.Types -import           System.Directory+import qualified System.Directory as D import           System.IO (withBinaryFile, IOMode (ReadMode)) import           System.IO.Error (isDoesNotExistError) @@ -176,7 +176,7 @@                 stackYamlFP <- asks $ bcStackYaml . getBuildConfig                 parseCustomMiniBuildPlan stackYamlFP url     rawLocals <- getLocalPackageViews-    workingDir <- getWorkingDir+    workingDir <- getCurrentDir      let snapshot = mpiVersion <$> mbpPackages mbp0     flagExtraDeps <- convertSnapshotToExtra@@ -227,7 +227,7 @@ getLocalPackageViews = do     econfig <- asks getEnvConfig     locals <- forM (Map.toList $ envConfigPackages econfig) $ \(dir, validWanted) -> do-        cabalfp <- getCabalFileName dir+        cabalfp <- findOrGenerateCabalFile dir         (warnings,gpkg) <- readPackageUnresolved cabalfp         mapM_ (printCabalFileWarning cabalfp) warnings         let cabalID = package $ packageDescription gpkg@@ -532,7 +532,7 @@         (catch              (liftM                   (Just . modTime)-                  (getModificationTime fp))+                  (D.getModificationTime fp))              (\e ->                    if isDoesNotExistError e                        then return Nothing
src/Stack/Build/Target.hs view
@@ -21,7 +21,7 @@  import           Control.Applicative import           Control.Arrow          (second)-import           Control.Monad.Catch    (MonadThrow, throwM)+import           Control.Monad.Catch    (MonadCatch, throwM) import           Control.Monad.IO.Class import           Data.Either            (partitionEithers) import           Data.Map               (Map)@@ -105,7 +105,7 @@     }  -- | Same as @parseRawTarget@, but also takes directories into account.-parseRawTargetDirs :: (MonadIO m, MonadThrow m)+parseRawTargetDirs :: (MonadIO m, MonadCatch m)                    => Path Abs Dir -- ^ current directory                    -> Map PackageName LocalPackageView                    -> Text@@ -114,7 +114,7 @@     case parseRawTarget t of         Just rt -> return $ Right [(ri, rt)]         Nothing -> do-            mdir <- resolveDirMaybe root $ T.unpack t+            mdir <- forgivingAbsence (resolveDir root (T.unpack t))             case mdir of                 Nothing -> return $ Left $ "Directory not found: " `T.append` t                 Just dir ->@@ -273,7 +273,7 @@     = NeedTargets     | AllowNoTargets -parseTargets :: (MonadThrow m, MonadIO m)+parseTargets :: (MonadCatch m, MonadIO m)              => NeedTargets -- ^ need at least one target              -> Bool -- ^ using implicit global project?              -> Map PackageName Version -- ^ snapshot
src/Stack/BuildPlan.hs view
@@ -10,10 +10,14 @@ -- snapshot.  module Stack.BuildPlan-    ( gpdPackages-    , BuildPlanException (..)+    ( BuildPlanException (..)     , BuildPlanCheck (..)     , checkSnapBuildPlan+    , DepError(..)+    , DepErrors+    , gpdPackageDeps+    , gpdPackages+    , gpdPackageName     , MiniBuildPlan(..)     , MiniPackageInfo(..)     , loadMiniBuildPlan@@ -23,8 +27,7 @@     , ToolMap     , getToolMap     , shadowMiniBuildPlan-    , showCompilerErrors-    , showDepErrors+    , showItems     , parseCustomMiniBuildPlan     ) where @@ -81,8 +84,8 @@ import           Stack.Package import           Stack.Types import           Stack.Types.StackT-import           System.Directory (canonicalizePath)-import qualified System.FilePath as FP+import qualified System.Directory as D+import qualified System.FilePath  as FP  data BuildPlanException     = UnknownPackages@@ -445,11 +448,11 @@         Right bp -> return bp         Left e -> do             $logDebug $ "Decoding build plan from file failed: " <> T.pack (show e)-            createTree (parent fp)+            ensureDir (parent fp)             req <- parseUrl $ T.unpack url             $logSticky $ "Downloading " <> renderSnapName name <> " build plan ..."             $logDebug $ "Downloading build plan from: " <> url-            _ <- download req { checkStatus = handle404 } fp+            _ <- redownload req { checkStatus = handle404 } fp             $logStickyDone $ "Downloaded " <> renderSnapName name <> " build plan."             liftIO (decodeFileEither $ toFilePath fp) >>= either throwM return @@ -652,6 +655,25 @@     | BuildPlanCheckFail    (Map PackageName (Map FlagName Bool)) DepErrors                             CompilerVersion +-- | Compare 'BuildPlanCheck', where GT means a better plan.+compareBuildPlanCheck :: BuildPlanCheck -> BuildPlanCheck -> Ordering+compareBuildPlanCheck (BuildPlanCheckPartial _ e1) (BuildPlanCheckPartial _ e2) =+    -- Note: order of comparison flipped, since it's better to have fewer errors.+    compare (Map.size e2) (Map.size e1)+compareBuildPlanCheck (BuildPlanCheckFail _ e1 _) (BuildPlanCheckFail _ e2 _) =+    let numUserPkgs e = Map.size $ Map.unions (Map.elems (fmap deNeededBy e))+    in compare (numUserPkgs e2) (numUserPkgs e1)+compareBuildPlanCheck BuildPlanCheckOk{}      BuildPlanCheckOk{}      = EQ+compareBuildPlanCheck BuildPlanCheckOk{}      BuildPlanCheckPartial{} = GT+compareBuildPlanCheck BuildPlanCheckOk{}      BuildPlanCheckFail{}    = GT+compareBuildPlanCheck BuildPlanCheckPartial{} BuildPlanCheckFail{}    = GT+compareBuildPlanCheck _                       _                       = LT++instance Show BuildPlanCheck where+    show BuildPlanCheckOk {} = ""+    show (BuildPlanCheckPartial f e)  = T.unpack $ showDepErrors f e+    show (BuildPlanCheckFail f e c) = T.unpack $ showCompilerErrors f e c+ -- | Check a set of 'GenericPackageDescription's and a set of flags against a -- given snapshot. Returns how well the snapshot satisfies the dependencies of -- the packages.@@ -697,77 +719,79 @@        , MonadBaseControl IO m)     => [GenericPackageDescription]     -> [SnapName]-    -> m (Maybe SnapName)+    -> m (SnapName, BuildPlanCheck) selectBestSnapshot gpds snaps = do     $logInfo $ "Selecting the best among "                <> T.pack (show (length snaps))                <> " snapshots...\n"     loop Nothing snaps     where-        loop Nothing [] = return Nothing-        loop (Just (snap, _)) [] = return $ Just snap+        loop Nothing []          = error "Bug: in best snapshot selection"+        loop (Just pair) []      = return pair         loop bestYet (snap:rest) = do             result <- checkSnapBuildPlan gpds Nothing snap             reportResult result snap+            let new = (snap, result)             case result of-                BuildPlanCheckFail _ _ _ -> loop bestYet rest-                BuildPlanCheckOk _ -> return $ Just snap-                BuildPlanCheckPartial _ e -> do-                    case bestYet of-                        Nothing -> loop (Just (snap, e)) rest-                        Just prev ->-                            loop (Just (betterSnap prev (snap, e))) rest+                BuildPlanCheckOk {} -> return new+                _ -> case bestYet of+                        Nothing  -> loop (Just new) rest+                        Just old -> loop (Just (betterSnap old new)) rest -        betterSnap (s1, e1) (s2, e2)-          | (Map.size e1) <= (Map.size e2) = (s1, e1)-          | otherwise = (s2, e2)+        betterSnap (s1, r1) (s2, r2)+          | compareBuildPlanCheck r1 r2 /= LT = (s1, r1)+          | otherwise = (s2, r2) -        reportResult (BuildPlanCheckOk _) snap = do-            $logInfo $ "* Selected " <> renderSnapName snap+        reportResult BuildPlanCheckOk {} snap = do+            $logInfo $ "* Matches " <> renderSnapName snap             $logInfo "" -        reportResult (BuildPlanCheckPartial f errs) snap = do+        reportResult r@BuildPlanCheckPartial {} snap = do             $logWarn $ "* Partially matches " <> renderSnapName snap-            $logWarn $ indent $ showDepErrors f errs+            $logWarn $ indent $ T.pack $ show r -        reportResult (BuildPlanCheckFail f errs compiler) snap = do+        reportResult r@BuildPlanCheckFail {} snap = do             $logWarn $ "* Rejected " <> renderSnapName snap-            $logWarn $ indent $ showCompilerErrors f errs compiler+            $logWarn $ indent $ T.pack $ show r          indent t = T.unlines $ fmap ("    " <>) (T.lines t) +showItems :: Show a => [a] -> Text+showItems items = T.concat (map formatItem items)+    where+        formatItem item = T.concat+            [ "    - "+            , T.pack $ show item+            , "\n"+            ]++showMapPackages :: Map PackageName a -> Text+showMapPackages mp = showItems $ Map.keys mp+ showCompilerErrors     :: Map PackageName (Map FlagName Bool)     -> DepErrors     -> CompilerVersion     -> Text showCompilerErrors flags errs compiler =-    -- TODO print the package filename to enable quick mapping for the user     T.concat         [ compilerVersionText compiler         , " cannot be used for these packages:\n"-        , T.concat (map formatError (Map.toList errs))+        , showMapPackages $ Map.unions (Map.elems (fmap deNeededBy errs))         , showDepErrors flags errs -- TODO only in debug mode         ]-    where-        formatError (_, DepError _ neededBy) = T.concat $-            map formatItem (Map.toList neededBy) -        formatItem (user, _) = T.concat-            [ "    - "-            , T.pack $ packageNameString user-            , "\n"-            ]- showDepErrors :: Map PackageName (Map FlagName Bool) -> DepErrors -> Text showDepErrors flags errs =-    T.concat $ map formatError (Map.toList errs)+    T.concat+        [ T.concat $ map formatError (Map.toList errs)+        , if T.null flagVals then ""+          else ("Using package flags:\n" <> flagVals)+        ]     where         formatError (depName, DepError mversion neededBy) = T.concat             [ showDepVersion depName mversion             , T.concat (map showRequirement (Map.toList neededBy))-            -- TODO only in debug-            , T.concat (map showFlags (Map.toList neededBy))             ]          showDepVersion depName mversion = T.concat@@ -790,15 +814,16 @@             , "\n"             ] -        showFlags (user, _) =-            maybe "" (printFlags user) (Map.lookup user flags)+        flagVals = T.concat (map showFlags userPkgs)+        userPkgs = Map.keys $ Map.unions (Map.elems (fmap deNeededBy errs))+        showFlags pkg = maybe "" (printFlags pkg) (Map.lookup pkg flags) -        printFlags user fl =+        printFlags pkg fl =             if (not $ Map.null fl) then                 T.concat                     [ "    - "-                    , T.pack $ packageNameString user-                    , " flags: "+                    , T.pack $ packageNameString pkg+                    , ": "                     , T.pack $ intercalate ", "                              $ map formatFlags (Map.toList fl)                     , "\n"@@ -895,7 +920,7 @@         return cacheFP      getYamlFPFromFile url = do-        fp <- liftIO $ canonicalizePath $ toFilePath (parent stackYamlFP) FP.</> T.unpack (fromMaybe url $+        fp <- liftIO $ D.canonicalizePath $ toFilePath (parent stackYamlFP) FP.</> T.unpack (fromMaybe url $             T.stripPrefix "file://" url <|> T.stripPrefix "file:" url)         parseAbsFile fp
src/Stack/Clean.hs view
@@ -8,21 +8,21 @@     ) where  import           Control.Exception (Exception)-import           Control.Monad.Catch (MonadThrow,throwM)+import           Control.Monad (when)+import           Control.Monad.Catch (MonadCatch, throwM) import           Control.Monad.IO.Class (MonadIO) import           Control.Monad.Logger (MonadLogger)-import           Control.Monad.Reader (MonadReader)+import           Control.Monad.Reader (MonadReader, asks) import           Data.Foldable (forM_) import           Data.List ((\\),intercalate) import qualified Data.Map.Strict as Map import           Data.Maybe (mapMaybe) import           Data.Typeable (Typeable)-import           Path.IO (removeTreeIfExists)+import           Path.IO (ignoringAbsence, removeDirRecur) import           Stack.Build.Source (getLocalPackageViews) import           Stack.Build.Target (LocalPackageView(..))-import           Stack.Constants (distDirFromDir)-import           Stack.Types (HasEnvConfig,PackageName)-+import           Stack.Constants (distDirFromDir, workDirFromDir)+import           Stack.Types (HasEnvConfig,PackageName, bcWorkDir, getBuildConfig)  -- | Reset the build, i.e. remove the @dist@ directory -- (for example @.stack-work\/dist\/x84_64-linux\/Cabal-1.22.4.0@)@@ -30,10 +30,19 @@ -- -- Throws 'StackCleanException'. clean-    :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m)+    :: (MonadCatch m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m)     => CleanOpts     -> m ()-clean (CleanOpts targets) = do+clean (CleanTargets targets) =+    cleanup targets False+clean (CleanFull _ ) =+    cleanup [] True++cleanup+    :: (MonadCatch m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m)+    => [PackageName] -> Bool+    -> m()+cleanup targets doFullClean = do     locals <- getLocalPackageViews     case targets \\ Map.keys locals of         [] -> do@@ -42,16 +51,24 @@                         then Map.elems locals -- default to cleaning all local packages                         else mapMaybe (`Map.lookup` locals) targets             forM_ lpvs $ \(LocalPackageView{lpvRoot = pkgDir},_) -> do-                distDir <- distDirFromDir pkgDir-                removeTreeIfExists distDir+                let delDir =+                          if doFullClean+                              then workDirFromDir pkgDir+                              else distDirFromDir pkgDir+                ignoringAbsence . removeDirRecur =<< delDir+            when doFullClean $ do+                bconfig <- asks getBuildConfig+                bcwd <- bcWorkDir bconfig+                ignoringAbsence (removeDirRecur bcwd)         pkgs -> throwM (NonLocalPackages pkgs)  -- | Options for cleaning a project.-newtype CleanOpts = CleanOpts+data CleanOpts = CleanTargets     { cleanOptsTargets :: [PackageName]     -- ^ Names of the packages to clean.     -- If the list is empty, every local package should be cleaned.     }+    | CleanFull { cleanOptsFull :: Bool }  -- | Exceptions during cleanup. newtype StackCleanException
src/Stack/Config.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-}@@ -30,15 +31,19 @@   ,getIsGMP4   ,getSnapshots   ,makeConcreteResolver+  ,checkOwnership+  ,getInContainer   ) where  import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Zip as Zip import qualified Codec.Compression.GZip as GZip import           Control.Applicative import           Control.Arrow ((***)) import           Control.Exception (assert)-import           Control.Monad+import           Control.Monad (liftM, unless, when, filterM) import           Control.Monad.Catch (MonadThrow, MonadCatch, catchAll, throwM)+import           Control.Monad.Extra (firstJustM) import           Control.Monad.IO.Class import           Control.Monad.Logger hiding (Loc) import           Control.Monad.Reader (MonadReader, ask, asks, runReaderT)@@ -48,6 +53,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Lazy as L+import           Data.Foldable (forM_) import qualified Data.IntMap as IntMap import qualified Data.Map as Map import           Data.Maybe@@ -65,6 +71,7 @@ import           Options.Applicative (Parser, strOption, long, help) import           Path import           Path.Extra (toFilePathNoTrailingSep)+import           Path.Find (findInParents) import           Path.IO import qualified Paths_stack as Meta import           Safe (headMay)@@ -76,9 +83,10 @@ import           Stack.PackageIndex import           Stack.Types import           Stack.Types.Internal-import           System.Directory (getAppUserDataDirectory, createDirectoryIfMissing, canonicalizePath) import           System.Environment import           System.IO+import           System.PosixCompat.Files (fileOwner, getFileStatus)+import           System.PosixCompat.User (getEffectiveUserID) import           System.Process.Read  -- | If deprecated path exists, use it and print a warning.@@ -120,7 +128,7 @@     --TEST no warning printed     liftM fst $ tryDeprecatedPath         Nothing-        dirExists+        doesDirExist         (implicitGlobalProjectDir stackRoot)         (implicitGlobalProjectDirDeprecated stackRoot)   where@@ -256,12 +264,12 @@      configLocalBin <-          case configMonoidLocalBinPath of              Nothing -> do-                 localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir+                 localDir <- getAppUserDataDir $(mkRelDir "local")                  return $ localDir </> $(mkRelDir "bin")              Just userPath ->                  (case mproject of                      -- Not in a project-                     Nothing -> parseRelAsAbsDir userPath+                     Nothing -> resolveDir' userPath                      -- Resolves to the project dir and appends the user path if it is relative                      Just (_, configYaml) -> resolveDir (parent configYaml) userPath)                  -- TODO: Either catch specific exceptions or add a@@ -288,6 +296,11 @@          configAllowNewer = fromMaybe False configMonoidAllowNewer          configDefaultTemplate = configMonoidDefaultTemplate +     configAllowDifferentUser <-+        case configMonoidAllowDifferentUser of+            Just True -> return True+            _ -> getInContainer+      return Config {..}  -- | Get the default 'GHCVariant'.  On older Linux systems with libgmp4, returns 'GHCGMP4'.@@ -364,7 +377,7 @@            -- ^ Override resolver            -> m (LoadConfig m) loadConfig configArgs mstackYaml mresolver = do-    stackRoot <- determineStackRoot+    (stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership     userConfigPath <- getDefaultUserConfigPath stackRoot     extraConfigs0 <- getExtraConfigs userConfigPath >>= mapM loadYaml     let extraConfigs =@@ -374,6 +387,11 @@                               (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = False}})                 extraConfigs0     mproject <- loadProjectConfig mstackYaml++    let printUserMessage (p, _, _) =+         maybe (return ()) ($logWarn . T.pack) (projectUserMsg p)+    maybe (return ()) printUserMessage mproject+     let mproject' = (\(project, stackYaml, _) -> (project, stackYaml)) <$> mproject     config <- configFromConfigMonoid stackRoot userConfigPath mresolver mproject' $ mconcat $         case mproject of@@ -381,10 +399,18 @@             Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs     unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config)         (throwM (BadStackVersionException (configRequireStackVersion config)))++    let mprojectRoot = fmap (\(_, fp, _) -> parent fp) mproject+    unless (configAllowDifferentUser config) $ do+        unless userOwnsStackRoot $+            throwM (UserDoesn'tOwnDirectory stackRoot)+        forM_ mprojectRoot $ \dir ->+            checkOwnership (dir </> configWorkDir config)+     return LoadConfig         { lcConfig          = config         , lcLoadBuildConfig = loadBuildConfig mproject config mresolver-        , lcProjectRoot     = fmap (\(_, fp, _) -> parent fp) mproject+        , lcProjectRoot     = mprojectRoot         }  -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@.@@ -408,8 +434,8 @@                 dest = destDir </> stackDotYaml                 dest' :: FilePath                 dest' = toFilePath dest-            createTree destDir-            exists <- fileExists dest+            ensureDir destDir+            exists <- doesFileExist dest             if exists                then do                    ProjectAndConfigMonoid project _ <- loadYaml dest@@ -435,7 +461,8 @@                    $logInfo ("Writing implicit global project config file to: " <> T.pack dest')                    $logInfo "Note: You can change the snapshot via the resolver field there."                    let p = Project-                           { projectPackages = mempty+                           { projectUserMsg = Nothing+                           , projectPackages = mempty                            , projectExtraDeps = mempty                            , projectFlags = mempty                            , projectResolver = r@@ -450,7 +477,7 @@                            , "# '", encodeUtf8 (T.pack $ toFilePath $ configUserConfigPath config), "' instead.\n"                            , "#\n"                            , "# For more information about stack's configuration, see\n"-                           , "# http://docs.haskellstack.org/en/stable/yaml_configuration.html\n"+                           , "# http://docs.haskellstack.org/en/stable/yaml_configuration/\n"                            , "#\n"                            , Yaml.encode p]                        S.writeFile (toFilePath $ parent dest </> $(mkRelFile "README.txt")) $ S.concat@@ -479,7 +506,7 @@                     return $ mbpCompilerVersion mbp                 ResolverCompiler wantedCompiler -> return wantedCompiler -    extraPackageDBs <- mapM parseRelAsAbsDir (projectExtraPackageDBs project)+    extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project)      packageCaches <- runReaderT (getMinimalEnvOverride >>= getPackageCaches) miniConfig @@ -514,7 +541,7 @@             subs -> mapM (resolveDir entryRoot) subs     case peValidWanted pe of         Nothing -> return ()-        Just _ -> $logWarn "Warning: you are using the deprecated valid-wanted field. You should instead use extra-dep. See: http://docs.haskellstack.org/en/stable/yaml_configuration.html#packages"+        Just _ -> $logWarn "Warning: you are using the deprecated valid-wanted field. You should instead use extra-dep. See: http://docs.haskellstack.org/en/stable/yaml_configuration/#packages"     return $ map (, not $ peExtraDep pe) paths  -- | Resolve a PackageLocation into a path, downloading and cloning as@@ -530,14 +557,14 @@ resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do     workDir <- getWorkDir     let nameBeforeHashing = case remotePackageType of-            RPTHttpTarball -> url+            RPTHttp        -> url             RPTGit commit  -> T.unwords [url, commit]             RPTHg  commit  -> T.unwords [url, commit, "hg"]         name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 nameBeforeHashing         root = projRoot </> workDir </> $(mkRelDir "downloaded")         fileExtension = case remotePackageType of-            RPTHttpTarball -> ".tar.gz"-            _              -> ".unused"+            RPTHttp -> ".http-archive"+            _       -> ".unused"      fileRel <- parseRelFile $ name ++ fileExtension     dirRel <- parseRelDir name@@ -546,12 +573,12 @@         dir = root </> dirRel         dirTmp = root </> dirRelTmp -    exists <- dirExists dir+    exists <- doesDirExist dir     unless exists $ do-        removeTreeIfExists dirTmp+        ignoringAbsence (removeDirRecur dirTmp)          let cloneAndExtract commandName resetCommand commit = do-                createTree (parent dirTmp)+                ensureDir (parent dirTmp)                 readInNull (parent dirTmp) commandName menv                     [ "clone"                     , T.unpack url@@ -564,46 +591,124 @@                       " exists within " <> url)          case remotePackageType of-            RPTHttpTarball -> do+            RPTHttp -> do+                let fp = toFilePath file                 req <- parseUrl $ T.unpack url                 _ <- download req file -                liftIO $ withBinaryFile (toFilePath file) ReadMode $ \h -> do-                    lbs <- L.hGetContents h-                    let entries = Tar.read $ GZip.decompress lbs-                    Tar.unpack (toFilePath dirTmp) entries+                let tryTar = do+                        $logDebug $ "Trying to untar " <> T.pack fp+                        liftIO $ withBinaryFile fp ReadMode $ \h -> do+                            lbs <- L.hGetContents h+                            let entries = Tar.read $ GZip.decompress lbs+                            Tar.unpack fp entries+                    tryZip = do+                        $logDebug $ "Trying to unzip " <> T.pack fp+                        archive <- fmap Zip.toArchive $ liftIO $ L.readFile fp+                        liftIO $  Zip.extractFilesFromArchive [Zip.OptDestination+                                                               (toFilePath dirTmp)] archive+                    err = throwM $ UnableToExtractArchive url file +                    catchAllLog goodpath handler =+                        catchAll goodpath $ \e -> do+                            $logDebug $ "Got exception: " <> T.pack (show e)+                            handler++                tryTar `catchAllLog` tryZip `catchAllLog` err+             RPTGit commit -> cloneAndExtract "git" ["reset", "--hard"] commit             RPTHg  commit -> cloneAndExtract "hg"  ["update", "-C"]    commit          renameDir dirTmp dir      case remotePackageType of-        RPTHttpTarball -> do-            x <- listDirectory dir-            case x of-                ([dir'], []) -> return dir'-                (dirs, files) -> do-                    removeFileIfExists file-                    removeTreeIfExists dir-                    throwM $ UnexpectedTarballContents dirs files-+        RPTHttp -> do x <- listDir dir+                      case x of+                          ([dir'], []) -> return dir'+                          (dirs, files) -> do+                              ignoringAbsence (removeFile file)+                              ignoringAbsence (removeDirRecur dir)+                              throwM $ UnexpectedArchiveContents dirs files         _ -> return dir --- | Get the stack root, e.g. ~/.stack-determineStackRoot :: (MonadIO m, MonadThrow m) => m (Path Abs Dir)-determineStackRoot = do-    env <- liftIO getEnvironment-    case lookup stackRootEnvVar env of-        Nothing -> do-            x <- liftIO $ getAppUserDataDirectory stackProgName-            parseAbsDir x-        Just x -> do-            y <- liftIO $ do-                createDirectoryIfMissing True x-                canonicalizePath x-            parseAbsDir y+-- | Get the stack root, e.g. @~/.stack@, and determine whether the user owns it.+--+-- On Windows, the second value is always 'True'.+determineStackRootAndOwnership+    :: (MonadIO m, MonadCatch m)+    => m (Path Abs Dir, Bool)+determineStackRootAndOwnership = do+    stackRoot <- do+        mstackRoot <- liftIO $ lookupEnv stackRootEnvVar+        case mstackRoot of+            Nothing -> getAppUserDataDir $(mkRelDir stackProgName)+            Just x -> parseAbsDir x +    (existingStackRootOrParentDir, userOwnsIt) <- do+        mdirAndOwnership <- findInParents getDirAndOwnership stackRoot+        case mdirAndOwnership of+            Just x -> return x+            Nothing -> throwM (BadStackRootEnvVar stackRoot)++    when (existingStackRootOrParentDir /= stackRoot) $+        if userOwnsIt+            then liftIO $ ensureDir stackRoot+            else throwM $+                Won'tCreateStackRootInDirectoryOwnedByDifferentUser+                    stackRoot+                    existingStackRootOrParentDir++    stackRoot' <- canonicalizePath stackRoot+    return (stackRoot', userOwnsIt)++-- | @'checkOwnership' dir@ throws 'UserDoesn'tOwnDirectory' if @dir@+-- isn't owned by the current user.+--+-- If @dir@ doesn't exist, its parent directory is checked instead.+-- If the parent directory doesn't exist either, @'NoSuchDirectory' ('parent' dir)@+-- is thrown.+checkOwnership :: (MonadIO m, MonadCatch m) => Path Abs Dir -> m ()+checkOwnership dir = do+    mdirAndOwnership <- firstJustM getDirAndOwnership [dir, parent dir]+    case mdirAndOwnership of+        Just (_, True) -> return ()+        Just (dir', False) -> throwM (UserDoesn'tOwnDirectory dir')+        Nothing ->+            (throwM . NoSuchDirectory) $ (toFilePathNoTrailingSep . parent) dir++-- | @'getDirAndOwnership' dir@ returns @'Just' (dir, 'True')@ when @dir@+-- exists and the current user owns it in the sense of 'isOwnedByUser'.+getDirAndOwnership+    :: (MonadIO m, MonadCatch m)+    => Path Abs Dir+    -> m (Maybe (Path Abs Dir, Bool))+getDirAndOwnership dir = forgivingAbsence $ do+    ownership <- isOwnedByUser dir+    return (dir, ownership)++-- | Check whether the current user (determined with 'getEffectiveUserId') is+-- the owner for the given path.+--+-- Will always return 'True' on Windows.+isOwnedByUser :: MonadIO m => Path Abs t -> m Bool+isOwnedByUser path = liftIO $ do+    if osIsWindows+        then return True+        else do+            fileStatus <- getFileStatus (toFilePath path)+            user <- getEffectiveUserID+            return (user == fileOwner fileStatus)+  where+#ifdef WINDOWS+    osIsWindows = True+#else+    osIsWindows = False+#endif++-- | 'True' if we are currently running inside a Docker container.+getInContainer :: (MonadIO m) => m Bool+getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar)+ -- | Determine the extra config file locations which exist. -- -- Returns most local first@@ -620,7 +725,7 @@     mstackGlobalConfig <-         maybe (return Nothing) (fmap Just . parseAbsFile)       $ lookup "STACK_GLOBAL_CONFIG" env-    filterM fileExists+    filterM doesFileExist         $ fromMaybe userConfigPath mstackConfig         : maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfigPath) @@ -645,28 +750,19 @@     case lookup "STACK_YAML" env of         Just fp -> do             $logInfo "Getting project config file from STACK_YAML environment"-            liftM Just $ case parseAbsFile fp of-                Left _ -> do-                    currDir <- getWorkingDir-                    resolveFile currDir fp-                Right path -> return path+            liftM Just $ resolveFile' fp         Nothing -> do-            currDir <- getWorkingDir-            search currDir+            currDir <- getCurrentDir+            findInParents getStackDotYaml currDir   where-    search dir = do+    getStackDotYaml dir = do         let fp = dir </> stackDotYaml             fp' = toFilePath fp         $logDebug $ "Checking for project config at: " <> T.pack fp'-        exists <- fileExists fp+        exists <- doesFileExist fp         if exists             then return $ Just fp-            else do-                let dir' = parent dir-                if dir == dir'-                    -- fully traversed, give up-                    then return Nothing-                    else search dir'+            else return Nothing  -- | Find the project config file location, respecting environment variables -- and otherwise traversing parents. If no config is found, we supply a default@@ -679,7 +775,7 @@     mfp <- getProjectConfig mstackYaml     case mfp of         Just fp -> do-            currDir <- getWorkingDir+            currDir <- getCurrentDir             $logDebug $ "Loading project config file " <>                         T.pack (maybe (toFilePath fp) toFilePath (stripDir currDir fp))             load fp@@ -703,7 +799,7 @@             liftM (Just . fst ) $             tryDeprecatedPath                 (Just "non-project global configuration file")-                fileExists+                doesFileExist                 new                 old         (Just new,Nothing) -> return (Just new)@@ -718,19 +814,18 @@ getDefaultUserConfigPath stackRoot = do     (path, exists) <- tryDeprecatedPath         (Just "non-project configuration file")-        fileExists+        doesFileExist         (defaultUserConfigPath stackRoot)         (defaultUserConfigPathDeprecated stackRoot)     unless exists $ do-        createTree (parent path)+        ensureDir (parent path)         liftIO $ S.writeFile (toFilePath path) $ S.concat             [ "# This file contains default non-project-specific settings for 'stack', used\n"             , "# in all projects.  For more information about stack's configuration, see\n"-            , "# http://docs.haskellstack.org/en/stable/yaml_configuration.html\n"+            , "# http://docs.haskellstack.org/en/stable/yaml_configuration/\n"             , "#\n"             , Yaml.encode (mempty :: Object) ]     return path-  packagesParser :: Parser [String] packagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))
src/Stack/Constants.hs view
@@ -10,6 +10,7 @@     ,configuredFileFromDir     ,defaultShakeThreads     ,distDirFromDir+    ,workDirFromDir     ,distRelativeDir     ,haskellModuleExts     ,imageStagingDir@@ -17,6 +18,7 @@     ,rawGithubUrl     ,stackDotYaml     ,stackRootEnvVar+    ,inContainerEnvVar     ,userDocsDir     ,configCacheFile     ,configCabalMod@@ -203,6 +205,13 @@ distDirFromDir fp =     liftM (fp </>) distRelativeDir +-- | Package's working directory.+workDirFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)+               => Path Abs Dir+               -> m (Path Abs Dir)+workDirFromDir fp =+    liftM (fp </>) getWorkDir+ -- | Directory for project templates. templatesDir :: Config -> Path Abs Dir templatesDir config = configStackRoot config </> $(mkRelDir "templates")@@ -291,6 +300,10 @@ -- | Environment variable used to override the '~/.stack' location. stackRootEnvVar :: String stackRootEnvVar = "STACK_ROOT"++-- | Environment variable used to indicate stack is running in container.+inContainerEnvVar :: String+inContainerEnvVar = stackProgNameUpper ++ "_IN_CONTAINER"  -- See https://downloads.haskell.org/~ghc/7.10.1/docs/html/libraries/ghc/src/Module.html#integerPackageKey wiredInPackages :: HashSet PackageName
+ src/Stack/Constants.hs-boot view
@@ -0,0 +1,3 @@+module Stack.Constants where++stackRootEnvVar :: String
src/Stack/Coverage.hs view
@@ -47,29 +47,28 @@ import           Stack.Constants import           Stack.Package import           Stack.Types-import qualified System.Directory as D import           System.FilePath (isPathSeparator) import           System.Process.Read import           Text.Hastache (htmlEscape) import           Trace.Hpc.Tix  -- | Invoked at the beginning of running with "--coverage"-deleteHpcReports :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)+deleteHpcReports :: (MonadIO m, MonadCatch m, MonadReader env m, HasEnvConfig env)                  => m () deleteHpcReports = do     hpcDir <- hpcReportDir-    removeTreeIfExists hpcDir+    ignoringAbsence (removeDirRecur hpcDir)  -- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is -- present. updateTixFile :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)             => PackageName -> Path Abs File -> String -> m () updateTixFile pkgName tixSrc testName = do-    exists <- fileExists tixSrc+    exists <- doesFileExist tixSrc     when exists $ do         tixDest <- tixFilePath pkgName testName-        removeFileIfExists tixDest-        createTree (parent tixDest)+        ignoringAbsence (removeFile tixDest)+        ensureDir (parent tixDest)         -- Remove exe modules because they are problematic. This could be revisited if there's a GHC         -- version that fixes https://ghc.haskell.org/trac/ghc/ticket/1853         mtix <- readTixOrLog tixSrc@@ -77,7 +76,7 @@             Nothing -> $logError $ "Failed to read " <> T.pack (toFilePath tixSrc)             Just tix -> do                 liftIO $ writeTix (toFilePath tixDest) (removeExeModules tix)-                removeFileIfExists tixSrc+                ignoringAbsence (removeFile tixSrc)  -- | Get the directory used for hpc reports for the given pkgId. hpcPkgPath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)@@ -138,7 +137,7 @@                           => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String] -> m () generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArgs = do     -- If a .tix file exists, move it to the HPC output directory and generate a report for it.-    tixFileExists <- fileExists tixSrc+    tixFileExists <- doesFileExist tixSrc     if not tixFileExists         then $logError $ T.concat             [ "Didn't find .tix for "@@ -242,32 +241,33 @@                                      " is used with a non test-suite target)"                      STLocalAll -> do                          pkgPath <- hpcPkgPath name-                         exists <- dirExists pkgPath+                         exists <- doesDirExist pkgPath                          if exists                              then do-                                 (_, files) <- listDirectory pkgPath+                                 (_, files) <- listDir pkgPath                                  return (filter ((".tix" `isSuffixOf`) . toFilePath) files)                              else return []-    tixPaths <- liftM (++ targetTixFiles) $ mapM (parseRelAsAbsFile . T.unpack) tixFiles+    tixPaths <- liftM (++ targetTixFiles) $ mapM (resolveFile' . T.unpack) tixFiles     when (null tixPaths) $         fail "Not generating combined report, because no targets or tix files are specified."     reportDir <- case hroptsDestDir opts of         Nothing -> liftM (</> $(mkRelDir "combined/custom")) hpcReportDir         Just destDir -> do-            liftIO $ D.createDirectoryIfMissing True destDir-            parseRelAsAbsDir destDir+            dest <- resolveDir' destDir+            ensureDir dest+            return dest     generateUnionReport "combined report" reportDir tixPaths  generateHpcUnifiedReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)                          => m () generateHpcUnifiedReport = do     outputDir <- hpcReportDir-    createTree outputDir-    (dirs, _) <- listDirectory outputDir+    ensureDir outputDir+    (dirs, _) <- listDir outputDir     tixFiles <- liftM (concat . concat) $ forM (filter (("combined" /=) . dirnameString) dirs) $ \dir -> do-        (dirs', _) <- listDirectory dir+        (dirs', _) <- listDir dir         forM dirs' $ \dir' -> do-            (_, files) <- listDirectory dir'+            (_, files) <- listDir dir'             return (filter ((".tix" `isSuffixOf`) . toFilePath) files)     let reportDir = outputDir </> $(mkRelDir "combined/all")     if length tixFiles < 2@@ -288,7 +288,7 @@         "The following modules are left out of the " : report : " due to version mismatches: " :         intersperse ", " (map T.pack errs)     tixDest <- liftM (reportDir </>) $ parseRelFile (dirnameString reportDir ++ ".tix")-    createTree (parent tixDest)+    ensureDir (parent tixDest)     liftIO $ writeTix (toFilePath tixDest) tix     generateHpcReportInternal tixDest reportDir report [] [] @@ -321,13 +321,13 @@ generateHpcMarkupIndex = do     outputDir <- hpcReportDir     let outputFile = outputDir </> $(mkRelFile "index.html")-    createTree outputDir-    (dirs, _) <- listDirectory outputDir+    ensureDir outputDir+    (dirs, _) <- listDir outputDir     rows <- liftM (catMaybes . concat) $ forM dirs $ \dir -> do-        (subdirs, _) <- listDirectory dir+        (subdirs, _) <- listDir dir         forM subdirs $ \subdir -> do             let indexPath = subdir </> $(mkRelFile "hpc_index.html")-            exists' <- fileExists indexPath+            exists' <- doesFileExist indexPath             if not exists' then return Nothing else do                 relPath <- stripDir outputDir indexPath                 let package = dirname dir@@ -372,7 +372,7 @@  generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Text -> m () generateHpcErrorReport dir err = do-    createTree dir+    ensureDir dir     liftIO $ T.writeFile (toFilePath (dir </> $(mkRelFile "hpc_index.html"))) $ T.concat         [ "<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\"></head><body>"         , "<h1>HPC Report Generation Error</h1>"@@ -397,7 +397,7 @@     distDir <- distDirFromDir pkgDir     path <- liftM (distDir </>) $         parseRelFile ("package.conf.inplace/" ++ packageIdentifierString pkgId ++ "-inplace.conf")-    exists <- fileExists path+    exists <- doesFileExist path     if exists         then do             contents <- liftIO $ T.readFile (toFilePath path)
src/Stack/Docker.hs view
@@ -56,16 +56,17 @@ import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path import           Path.Extra (toFilePathNoTrailingSep)-import           Path.IO+import           Path.IO hiding (canonicalizePath) import qualified Paths_stack as Meta import           Prelude -- Fix redundant import warnings+import           Stack.Config (getInContainer) import           Stack.Constants import           Stack.Docker.GlobalDB import           Stack.Types import           Stack.Types.Internal import           Stack.Setup (ensureDockerStackExe)-import           System.Directory (canonicalizePath,getModificationTime)-import           System.Environment (getEnv,getProgName,getArgs,getExecutablePath,lookupEnv)+import           System.Directory (canonicalizePath,getHomeDirectory)+import           System.Environment (getEnv,getEnvironment,getProgName,getArgs,getExecutablePath) import           System.Exit (exitSuccess, exitWith) import qualified System.FilePath as FP import           System.IO (stderr,stdin,stdout,hIsTerminalDevice)@@ -141,7 +142,7 @@                   (exePath,exeTimestamp,misCompatible) <-                       liftIO $                       do exePath <- liftIO getExecutablePath-                         exeTimestamp <- liftIO (getModificationTime exePath)+                         exeTimestamp <- resolveFile' exePath >>= getModificationTime                          isKnown <-                              liftIO $                              getDockerImageExe@@ -237,10 +238,6 @@         then throwM OnlyOnHostException         else inner --- | 'True' if we are currently running inside a Docker container.-getInContainer :: (MonadIO m) => m Bool-getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar)- -- | Run a command in a new Docker container, then exit the process. runContainerAndExit :: M env m   => GetCmdArgs env m@@ -256,20 +253,26 @@      let docker = configDocker config      envOverride <- getEnvOverride (configPlatform config)      checkDockerVersion envOverride docker-     (dockerHost,dockerCertPath,bamboo,jenkins) <--       liftIO ((,,,) <$> lookupEnv "DOCKER_HOST"-                     <*> lookupEnv "DOCKER_CERT_PATH"-                     <*> lookupEnv "bamboo_buildKey"-                     <*> lookupEnv "JENKINS_HOME")-     let isRemoteDocker = maybe False (isPrefixOf "tcp://") dockerHost+     (env,isStdinTerminal,isStderrTerminal,homeDir) <- liftIO $+       (,,,)+       <$> getEnvironment+       <*> hIsTerminalDevice stdin+       <*> hIsTerminalDevice stderr+       <*> (parseAbsDir =<< getHomeDirectory)      isStdoutTerminal <- asks getTerminal-     (isStdinTerminal,isStderrTerminal) <--       liftIO ((,) <$> hIsTerminalDevice stdin-                   <*> hIsTerminalDevice stderr)+     let sshDir = homeDir </> sshRelDir+     sshDirExists <- doesDirExist sshDir+     let dockerHost = lookup "DOCKER_HOST" env+         dockerCertPath = lookup "DOCKER_CERT_PATH" env+         bamboo = lookup "bamboo_buildKey" env+         jenkins = lookup "JENKINS_HOME" env+         msshAuthSock = lookup "SSH_AUTH_SOCK" env+         muserEnv = lookup "USER" env+         isRemoteDocker = maybe False (isPrefixOf "tcp://") dockerHost+         image = dockerImage docker      when (isRemoteDocker &&            maybe False (isInfixOf "boot2docker") dockerCertPath)           ($logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.")-     let image = dockerImage docker      maybeImageInfo <- inspect envOverride image      imageInfo@Inspect{..} <- case maybeImageInfo of        Just ii -> return ii@@ -302,10 +305,10 @@                                             </> $(mkRelDir ".local/bin")]                       (T.pack <$> lookupImageEnv "PATH" imageEnvVars)      (cmnd,args,envVars,extraMount) <- getCmdArgs docker envOverride imageInfo isRemoteDocker-     pwd <- getWorkingDir+     pwd <- getCurrentDir      liftIO        (do updateDockerImageLastUsed config iiId (toFilePath projectRoot)-           mapM_ createTree [sandboxHomeDir, stackRoot])+           mapM_ (ensureDir) [sandboxHomeDir, stackRoot])      containerID <- (trim . decodeUtf8) <$> readDockerProcess        envOverride        (concat@@ -316,10 +319,23 @@           ,"-e",platformVariantEnvVar ++ "=dk" ++ platformVariant           ,"-e","HOME=" ++ toFilePathNoTrailingSep sandboxHomeDir           ,"-e","PATH=" ++ T.unpack newPathEnv+          ,"-e","PWD=" ++ toFilePathNoTrailingSep pwd           ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot           ,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot           ,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxHomeDir           ,"-w",toFilePathNoTrailingSep pwd]+         ,case muserEnv of+            Nothing -> []+            Just userEnv -> ["-e","USER=" ++ userEnv]+         ,if sshDirExists+          then ["-v",toFilePathNoTrailingSep sshDir ++ ":" +++                     toFilePathNoTrailingSep (sandboxHomeDir </> sshRelDir)]+          else []+         ,case msshAuthSock of+            Nothing -> []+            Just sshAuthSock ->+              ["-e","SSH_AUTH_SOCK=" ++ sshAuthSock+              ,"-v",sshAuthSock ++ ":" ++ sshAuthSock]            -- Disable the deprecated entrypoint in FP Complete-generated images          ,["--entrypoint=/usr/bin/env"              | isJust (lookupImageEnv oldSandboxIdEnvVar imageEnvVars) &&@@ -386,6 +402,7 @@         _ -> Nothing     mountArg (Mount host container) = ["-v",host ++ ":" ++ container]     projectRoot = fromMaybeProjectRoot mprojectRoot+    sshRelDir = $(mkRelDir ".ssh/")  -- | Clean-up old docker images and containers. cleanup :: M env m@@ -681,7 +698,7 @@      dockerVersionOut <- readDockerProcess envOverride ["--version"]      case words (decodeUtf8 dockerVersionOut) of        (_:_:v:_) ->-         case parseVersionFromString (dropWhileEnd (not . isDigit) v) of+         case parseVersionFromString (stripVersion v) of            Just v'              | v' < minimumDockerVersion ->                throwM (DockerTooOldException minimumDockerVersion v')@@ -695,6 +712,7 @@        _ -> throwM InvalidVersionOutputException   where minimumDockerVersion = $(mkVersion "1.6.0")         prohibitedDockerVersions = []+        stripVersion v = fst $ break (== '-') $ dropWhileEnd (not . isDigit) v  -- | Remove the project's Docker sandbox. reset :: (MonadIO m, MonadReader env m, HasConfig env)@@ -732,19 +750,19 @@           -- its original home directory to the host's stack root, to avoid needing to download them           origStackHomeDir <- parseAbsDir (User.homeDirectory ue)           let origStackRoot = origStackHomeDir </> $(mkRelDir ("." ++ stackProgName))-          buildPlanDirExists <- dirExists (buildPlanDir origStackRoot)+          buildPlanDirExists <- doesDirExist (buildPlanDir origStackRoot)           when buildPlanDirExists $ do-            (_, buildPlans) <- listDirectory (buildPlanDir origStackRoot)+            (_, buildPlans) <- listDir (buildPlanDir origStackRoot)             forM_ buildPlans $ \srcBuildPlan -> do               let destBuildPlan = buildPlanDir configStackRoot </> filename srcBuildPlan-              exists <- fileExists destBuildPlan+              exists <- doesFileExist destBuildPlan               unless exists $ do-                createTree (parent destBuildPlan)+                ensureDir (parent destBuildPlan)                 copyFile srcBuildPlan destBuildPlan           forM_ configPackageIndices $ \pkgIdx -> do             msrcIndex <- flip runReaderT (config{configStackRoot = origStackRoot}) $ do                srcIndex <- configPackageIndex (indexName pkgIdx)-               exists <- fileExists srcIndex+               exists <- doesFileExist srcIndex                return $ if exists                  then Just srcIndex                  else Nothing@@ -753,9 +771,9 @@               Just srcIndex -> do                 flip runReaderT config $ do                   destIndex <- configPackageIndex (indexName pkgIdx)-                  exists <- fileExists destIndex+                  exists <- doesFileExist destIndex                   unless exists $ do-                    createTree (parent destIndex)+                    ensureDir (parent destIndex)                     copyFile srcIndex destIndex     return True   where@@ -813,12 +831,12 @@                         -> [Path Rel File] -- ^ Top-level file names to exclude from removal                         -> IO () removeDirectoryContents path excludeDirs excludeFiles =-  do isRootDir <- dirExists path+  do isRootDir <- doesDirExist path      when isRootDir-          (do (lsd,lsf) <- listDirectory path+          (do (lsd,lsf) <- listDir path               forM_ lsd                     (\d -> unless (dirname d `elem` excludeDirs)-                                  (removeTree d))+                                  (removeDirRecur d))               forM_ lsf                     (\f -> unless (filename f `elem` excludeFiles)                                   (removeFile f)))@@ -856,10 +874,6 @@ oldSandboxIdEnvVar :: String oldSandboxIdEnvVar = "DOCKER_SANDBOX_ID" --- | Environment variable used to indicate stack is running in container.-inContainerEnvVar :: String-inContainerEnvVar = stackProgNameUpper ++ "_IN_CONTAINER"- -- | Command-line argument for "docker" dockerCmdName :: String dockerCmdName = "docker"@@ -1067,7 +1081,6 @@   -> Inspect   -> Bool   -> m (FilePath,[String],[(String,String)],[Mount])-  type M env m = (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadCatch m                ,HasConfig env,HasTerminal env,HasReExec env,HasHttpManager env,MonadMask m)
src/Stack/Docker/GlobalDB.hs view
@@ -29,7 +29,7 @@ import           Database.Persist.Sqlite import           Database.Persist.TH import           Path (toFilePath, parent)-import           Path.IO (createTree)+import           Path.IO (ensureDir) import           Stack.Types.Config import           Stack.Types.Docker @@ -100,7 +100,7 @@ withGlobalDB :: forall a. Config -> SqlPersistT (NoLoggingT (ResourceT IO)) a -> IO a withGlobalDB config action =   do let db = dockerDatabasePath (configDocker config)-     createTree (parent db)+     ensureDir (parent db)      runSqlite (T.pack (toFilePath db))                (do _ <- runMigrationSilent migrateTables                    action)
src/Stack/Fetch.hs view
@@ -65,15 +65,12 @@ import           Data.Word                      (Word64) import           Network.HTTP.Download import           Path-import           Path.IO                         (dirExists, createTree)+import           Path.IO import           Prelude -- Fix AMP warning import           Stack.GhcPkg import           Stack.PackageIndex import           Stack.Types-import           System.Directory               (canonicalizePath,-                                                 createDirectoryIfMissing,-                                                 doesDirectoryExist,-                                                 renameDirectory)+import qualified System.Directory               as D import           System.FilePath                ((<.>)) import qualified System.FilePath                as FP import           System.IO                      (IOMode (ReadMode),@@ -140,7 +137,7 @@                -> [String] -- ^ names or identifiers                -> m () unpackPackages menv dest input = do-    dest' <- liftIO (canonicalizePath dest) >>= parseAbsDir+    dest' <- resolveDir' dest     (names, idents) <- case partitionEithers $ map parse input of         ([], x) -> return $ partitionEithers x         (errs, _) -> throwM $ CouldNotParsePackageSelectors errs@@ -384,7 +381,7 @@             case mdestDir of                 Nothing -> return Nothing                 Just destDir -> do-                    exists <- dirExists destDir+                    exists <- doesDirExist destDir                     return $ if exists then Just destDir else Nothing         case mexists of             Just destDir -> return $ Right (ident, destDir)@@ -465,7 +462,7 @@             let dest = toFilePath $ parent destDir                 innerDest = toFilePath destDir -            liftIO $ createDirectoryIfMissing True dest+            liftIO $ ensureDir (parent destDir)              liftIO $ withBinaryFile fp ReadMode $ \h -> do                 -- Avoid using L.readFile, which is more likely to leak@@ -498,15 +495,15 @@                         let inner = dest FP.</> identStr                             oldDist = inner FP.</> "dist"                             newDist = inner FP.</> toFilePath distDir-                        exists <- doesDirectoryExist oldDist+                        exists <- D.doesDirectoryExist 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-                            createTree . parent =<< parseAbsDir newDist-                            renameDirectory oldDist newDist+                            ensureDir . parent =<< parseAbsDir newDist+                            D.renameDirectory oldDist newDist                  let cabalFP =                         innerDest FP.</>
src/Stack/GhcPkg.hs view
@@ -32,25 +32,24 @@ import           Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T-import           Path (Path, Abs, Dir, toFilePath, parent, parseAbsDir)+import           Path (Path, Abs, Dir, toFilePath, parent) import           Path.Extra (toFilePathNoTrailingSep)-import           Path.IO (dirExists, createTree)+import           Path.IO import           Prelude hiding (FilePath) import           Stack.Constants import           Stack.Types-import           System.Directory (canonicalizePath) import           System.FilePath (searchPathSeparator) import           System.Process.Read  -- | Get the global package database-getGlobalDB :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+getGlobalDB :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)             => EnvOverride -> WhichCompiler -> m (Path Abs Dir) getGlobalDB menv wc = do     -- This seems like a strange way to get the global package database     -- location, but I don't know of a better one     bs <- ghcPkg menv wc [] ["list", "--global"] >>= either throwM return     let fp = S8.unpack $ stripTrailingColon $ firstLine bs-    liftIO (canonicalizePath fp) >>= parseAbsDir+    resolveDir' fp   where     stripTrailingColon bs         | S8.null bs = bs@@ -80,12 +79,12 @@ createDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)                => EnvOverride -> WhichCompiler -> Path Abs Dir -> m () createDatabase menv wc db = do-    exists <- dirExists db+    exists <- doesDirExist db     unless exists $ do         -- Creating the parent doesn't seem necessary, as ghc-pkg         -- seems to be sufficiently smart. But I don't feel like         -- finding out it isn't the hard way-        createTree (parent db)+        ensureDir (parent db)         _ <- tryProcessStdout Nothing menv (ghcPkgExeName wc) ["init", toFilePath db]         return ()
src/Stack/Ghci.hs view
@@ -11,6 +11,7 @@ module Stack.Ghci     ( GhciOpts(..)     , GhciPkgInfo(..)+    , GhciException(..)     , ghciSetup     , ghci     ) where@@ -36,6 +37,7 @@ import qualified Data.Set as S import           Data.Text (Text) import qualified Data.Text as T+import           Data.Typeable (Typeable) import           Distribution.ModuleName (ModuleName) import           Distribution.Text (display) import           Network.HTTP.Client.Conduit@@ -52,8 +54,7 @@ import           Stack.Package import           Stack.Types import           Stack.Types.Internal-import           System.Directory (getTemporaryDirectory)-import Text.Read (readMaybe)+import           Text.Read (readMaybe)  #ifndef WINDOWS import qualified System.Posix.Files as Posix@@ -67,6 +68,7 @@     , ghciNoLoadModules      :: !Bool     , ghciAdditionalPackages :: ![String]     , ghciMainIs             :: !(Maybe Text)+    , ghciLoadLocalDeps      :: !Bool     , ghciSkipIntermediate   :: !Bool     , ghciHidePackages       :: !Bool     , ghciBuildOpts          :: !BuildOpts@@ -84,18 +86,33 @@     , ghciPkgPackage :: !Package     } deriving Show +data GhciException+    = InvalidPackageOption String+    | LoadingDuplicateModules+    deriving (Typeable)++instance Exception GhciException++instance Show GhciException where+    show (InvalidPackageOption name) =+        "Failed to parse --package option " ++ name+    show LoadingDuplicateModules = unlines+        [ "Not attempting to start ghci due to these duplicate modules."+        , "Use --no-load to try to start it anyway, without loading any modules (but these are still likely to cause errors)"+        ]+ -- | Launch a GHCi session for the given local package targets with the -- given options and configure it with the load paths and extensions -- of those targets. ghci     :: (HasConfig r, HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m)     => GhciOpts -> m ()-ghci GhciOpts{..} = do+ghci opts@GhciOpts{..} = do     let bopts = ghciBuildOpts             { boptsTestOpts = (boptsTestOpts ghciBuildOpts) { toDisableRun = True }             , boptsBenchmarkOpts = (boptsBenchmarkOpts ghciBuildOpts) { beoDisableRun = True }             }-    (targets,mainIsTargets,pkgs) <- ghciSetup bopts ghciNoBuild ghciSkipIntermediate ghciMainIs ghciAdditionalPackages+    (targets,mainIsTargets,pkgs) <- ghciSetup opts { ghciBuildOpts = bopts }     config <- asks getConfig     bconfig <- asks getBuildConfig     wc <- getWhichCompiler@@ -117,12 +134,12 @@         $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     oiDir <- objectInterfaceDir bconfig     (modulesToLoad, thingsToLoad) <- if ghciNoLoadModules then return ([], []) else do         mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs-        let modulesToLoad = nubOrd $ concatMap (map display . S.toList . ghciPkgModules) pkgs-            thingsToLoad = maybe [] (return . toFilePath) mainFile <> modulesToLoad-        return (modulesToLoad, thingsToLoad)+        let thingsToLoad = maybe [] (return . toFilePath) mainFile <> allModules+        return (allModules, thingsToLoad)     let odir =             [ "-odir=" <> toFilePathNoTrailingSep oiDir             , "-hidir=" <> toFilePathNoTrailingSep oiDir ]@@ -138,8 +155,7 @@                  -- include CWD.                   "-i" :                   odir <> pkgopts <> ghciArgs <> extras)-    tmp <- liftIO getTemporaryDirectory-    withCanonicalizedTempDirectory tmp "ghci" $ \tmpDir -> do+    withSystemTempDir "ghci" $ \tmpDir -> do         let macrosFile = tmpDir </> $(mkRelFile "cabal_macros.h")         macrosOpts <- preprocessCabalMacros pkgs macrosFile         if ghciNoLoadModules@@ -244,27 +260,32 @@ -- information to load that package/components. ghciSetup     :: (HasConfig r, HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m)-    => BuildOpts-    -> Bool-    -> Bool-    -> Maybe Text-    -> [String]+    => GhciOpts     -> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo])-ghciSetup bopts0 noBuild skipIntermediate mainIs additionalPackages = do+ghciSetup GhciOpts{..} = do+    let bopts0 = ghciBuildOpts     (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets bopts0     mainIsTargets <--        case mainIs of+        case ghciMainIs of             Nothing -> return Nothing             Just target -> do                 (_,_,targets') <- parseTargetsFromBuildOpts AllowNoTargets bopts0 { boptsTargets = [target] }                 return (Just targets')-    addPkgs <- forM additionalPackages $ \name -> do+    addPkgs <- forM ghciAdditionalPackages $ \name -> do         let mres = (packageIdentifierName <$> parsePackageIdentifierFromString name)                 <|> parsePackageNameFromString name-        maybe (fail $ "Failed to parse --package option " ++ name) return mres+        maybe (throwM $ InvalidPackageOption name) return mres     let bopts = bopts0-            { boptsTargets = boptsTargets bopts0 ++ map T.pack additionalPackages+            { boptsTargets = boptsTargets bopts0 ++ map T.pack ghciAdditionalPackages             }+    -- Try to build, but optimistically launch GHCi anyway if it fails (#1065)+    unless ghciNoBuild $ do+        eres <- tryAny $ build (const (return ())) Nothing bopts+        case eres of+            Right () -> return ()+            Left err -> do+                $logError $ T.pack (show err)+                $logWarn "Warning: build failed, but optimistically launching GHCi anyway"     econfig <- asks getEnvConfig     (realTargets,_,_,_,sourceMap) <- loadSourceMap AllowNoTargets bopts     menv <- getMinimalEnvOverride@@ -278,7 +299,7 @@     directlyWanted <-         forMaybeM (M.toList (envConfigPackages econfig)) $         \(dir,validWanted) ->-             do cabalfp <- getCabalFileName dir+             do cabalfp <- findOrGenerateCabalFile dir                 name <- parsePackageNameFromFilePath cabalfp                 if validWanted                     then case M.lookup name targets of@@ -286,28 +307,27 @@                                  return (Just (name, (cabalfp, simpleTargets)))                              Nothing -> return Nothing                     else return Nothing-    let intermediateDeps = getIntermediateDeps sourceMap directlyWanted+    let extraLoadDeps = getExtraLoadDeps ghciLoadLocalDeps sourceMap directlyWanted     wanted <--        if skipIntermediate || null intermediateDeps+        if (ghciSkipIntermediate && not ghciLoadLocalDeps) || null extraLoadDeps             then return directlyWanted             else do-                $logInfo $ T.concat-                    [ "The following libraries will also be loaded into GHCi because "-                    , "they are intermediate dependencies of your targets:\n    "-                    , T.intercalate ", " (map (packageNameText . fst) intermediateDeps)-                    , "\n(Use --skip-intermediate-deps to omit these)"-                    ]-                return (directlyWanted ++ intermediateDeps)-    -- Try to build, but optimistically launch GHCi anyway if it fails (#1065)-    unless noBuild $ do-        eres <- tryAny $ build (const (return ())) Nothing bopts-        case eres of-            Right () -> return ()-            Left err -> do-                $logError $ T.pack (show err)-                $logWarn "Warning: build failed, but optimistically launching GHCi anyway"+                let extraList = T.intercalate ", " (map (packageNameText . fst) extraLoadDeps)+                if ghciLoadLocalDeps+                    then $logInfo $ T.concat+                        [ "The following libraries will also be loaded into GHCi because "+                        , "they are local dependencies of your targets, and you specified --load-local-deps:\n    "+                        , extraList+                        ]+                    else $logInfo $ T.concat+                        [ "The following libraries will also be loaded into GHCi because "+                        , "they are intermediate dependencies of your targets:\n    "+                        , extraList+                        , "\n(Use --skip-intermediate-deps to omit these)"+                        ]+                return (directlyWanted ++ extraLoadDeps)     -- Load the list of modules _after_ building, to catch changes in unlisted dependencies (#1180)-    let localLibs = [name | (name, (_, target)) <- wanted , hasLocalComp isCLib target]+    let localLibs = [name | (name, (_, target)) <- wanted, hasLocalComp isCLib target]     infos <-         forM wanted $         \(name,(cabalfp,target)) ->@@ -446,15 +466,35 @@     $logWarn ""     return x +checkForDuplicateModules :: (MonadThrow m, MonadLogger m) => Bool -> [GhciPkgInfo] -> m [String]+checkForDuplicateModules noLoadModules 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)+  where+    duplicates, allModules :: [(String, [PackageName])]+    duplicates = filter (not . null . tail . snd) allModules+    allModules =+        M.toList $ M.fromListWith (++) $+        concatMap (\pkg -> map (, [ghciPkgName pkg]) (map display (S.toList (ghciPkgModules pkg)))) pkgs+ -- Adds in intermediate dependencies between ghci targets. Note that it -- will return a Lib component for these intermediate dependencies even -- if they don't have a library (but that's fine for the usage within -- this module).-getIntermediateDeps-    :: SourceMap+--+-- If 'True' is passed for loadAllDeps, this loads all local deps, even+-- if they aren't intermediate.+getExtraLoadDeps+    :: Bool+    -> SourceMap     -> [(PackageName, (Path Abs File, SimpleTarget))]     -> [(PackageName, (Path Abs File, SimpleTarget))]-getIntermediateDeps sourceMap targets =+getExtraLoadDeps loadAllDeps sourceMap targets =     M.toList $     (\mp -> foldl' (flip M.delete) mp (map fst targets)) $     M.mapMaybe id $@@ -471,19 +511,19 @@         cache <- get         case (M.lookup name cache, M.lookup name sourceMap) of             (Just (Just _), _) -> return True-            (Just Nothing, _) -> return False+            (Just Nothing, _) | not loadAllDeps -> return False             (_, Just (PSLocal lp)) -> do                 let deps = M.keys (packageDeps (lpPackage lp))-                isIntermediate <- liftM or $ mapM go deps-                if isIntermediate+                shouldLoad <- liftM or $ mapM go deps+                if shouldLoad                     then do                         modify (M.insert name (Just (lpCabalFile lp, STLocalComps (S.singleton CLib))))                         return True                     else do                         modify (M.insert name Nothing)                         return False-            (_, Just PSUpstream{}) -> return False-            (Nothing, Nothing) -> return False+            (_, Just PSUpstream{}) -> return loadAllDeps+            (_, _) -> return False  preprocessCabalMacros :: MonadIO m => [GhciPkgInfo] -> Path Abs File -> m [String] preprocessCabalMacros pkgs out = liftIO $ do
src/Stack/Ide.hs view
@@ -8,7 +8,7 @@ -- | Run a IDE configured with the user's package(s).  module Stack.Ide-    (ide, getPackageOptsAndTargetFiles)+    (ide, getPackageOptsAndTargetFiles, ideGhciOpts)     where  import           Control.Monad.Catch@@ -27,7 +27,7 @@ import           Path.Extra (toFilePathNoTrailingSep) import           Path.IO import           Stack.Constants-import           Stack.Ghci (GhciPkgInfo(..), ghciSetup)+import           Stack.Ghci (GhciPkgInfo(..), GhciOpts(..), ghciSetup) import           Stack.Package import           Stack.Types import           Stack.Types.Internal@@ -48,8 +48,8 @@             { boptsTargets = targets             , boptsBuildSubset = BSOnlyDependencies             }-    (_realTargets,_,pkgs) <- ghciSetup bopts False False Nothing []-    pwd <- getWorkingDir+    (_realTargets,_,pkgs) <- ghciSetup (ideGhciOpts bopts)+    pwd <- getCurrentDir     (pkgopts,_srcfiles) <-         liftM mconcat $ forM pkgs $ getPackageOptsAndTargetFiles pwd     localdb <- packageDatabaseLocal@@ -96,7 +96,7 @@             (autogen </>)             (parseRelFile                  ("Paths_" ++ packageNameString (ghciPkgName pkg) ++ ".hs"))-    paths_foo_exists <- fileExists paths_foo+    paths_foo_exists <- doesFileExist paths_foo     let ghcOptions bio =             bioOneWordOpts bio ++             bioOpts bio ++@@ -109,3 +109,17 @@               (fmap toFilePath . stripDir pwd)               (S.toList (ghciPkgCFiles pkg) <> S.toList (ghciPkgModFiles pkg) <>                [paths_foo | paths_foo_exists]))++ideGhciOpts :: BuildOpts -> GhciOpts+ideGhciOpts bopts = GhciOpts+    { ghciNoBuild = False+    , ghciArgs = []+    , ghciGhcCommand = Nothing+    , ghciNoLoadModules = False+    , ghciAdditionalPackages = []+    , ghciMainIs = Nothing+    , ghciLoadLocalDeps = False+    , ghciSkipIntermediate = False+    , ghciHidePackages = True+    , ghciBuildOpts = bopts+    }
src/Stack/Image.hs view
@@ -41,11 +41,11 @@ stageContainerImageArtifacts :: Build e m => m () stageContainerImageArtifacts = do     config <- asks getConfig-    workingDir <- getWorkingDir+    workingDir <- getCurrentDir     forM_ (zip [0..] $ imgDockers $ configImage config) $ \(idx, opts) -> do         imageDir <- imageStagingDir workingDir idx-        removeTreeIfExists imageDir-        createTree imageDir+        ignoringAbsence (removeDirRecur imageDir)+        ensureDir imageDir         stageExesInDir opts imageDir         syncAddContentToDir opts imageDir @@ -56,7 +56,7 @@ createContainerImageFromStage :: Assemble e m => m () createContainerImageFromStage = do     config <- asks getConfig-    workingDir <- getWorkingDir+    workingDir <- getCurrentDir     forM_ (zip [0..] $ imgDockers $ configImage config) $ \(idx, opts) -> do         imageDir <- imageStagingDir workingDir idx         createDockerImage opts imageDir@@ -70,9 +70,9 @@         liftM (</> $(mkRelDir "bin")) installationRootLocal     let destBinPath = dir </>             $(mkRelDir "usr/local/bin")-    createTree destBinPath+    ensureDir destBinPath     case imgDockerExecutables opts of-        Nothing -> copyDirectoryRecursive srcBinPath destBinPath+        Nothing -> copyDirRecur srcBinPath destBinPath         Just exes -> forM_ exes $ \exe -> do             exeRelFile <- parseRelFile exe             copyFile (srcBinPath </> exeRelFile) (destBinPath </> exeRelFile)@@ -89,8 +89,8 @@               do sourcePath <- parseRelDir source                  destPath <- parseAbsDir dest                  let destFullPath = dir </> dropRoot destPath-                 createTree destFullPath-                 copyDirectoryRecursive+                 ensureDir destFullPath+                 copyDirRecur                      (bcRoot bconfig </> sourcePath)                      destFullPath) @@ -119,7 +119,6 @@                              (imgDockerImageName dockerConfig)                        , toFilePathNoTrailingSep dir]             callProcess $ Cmd Nothing "docker" menv args-  -- | Extend the general purpose docker image with entrypoints (if -- specified).
src/Stack/Init.hs view
@@ -5,28 +5,28 @@ module Stack.Init     ( initProject     , InitOpts (..)-    , SnapPref (..)-    , Method (..)     ) where  import           Control.Exception               (assert)-import           Control.Exception.Enclosed      (catchAny, handleIO)-import           Control.Monad                   (liftM, when)+import           Control.Exception.Enclosed      (catchAny)+import           Control.Monad import           Control.Monad.Catch             (MonadMask, throwM) import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.Reader            (MonadReader)+import           Control.Monad.Reader            (MonadReader, asks) import           Control.Monad.Trans.Control     (MonadBaseControl) import qualified Data.ByteString.Builder         as B+import qualified Data.ByteString.Char8           as BC import qualified Data.ByteString.Lazy            as L+import qualified Data.Foldable                   as F+import           Data.Function                   (on) import qualified Data.HashMap.Strict             as HM import qualified Data.IntMap                     as IntMap-import qualified Data.Foldable                   as F-import           Data.List                       (sortBy)+import           Data.List                       (intersect, maximumBy) import           Data.List.Extra                 (nubOrd) import           Data.Map                        (Map) import qualified Data.Map                        as Map-import           Data.Maybe                      (mapMaybe)+import           Data.Maybe                      (fromJust) import           Data.Monoid import qualified Data.Text                       as T import qualified Data.Yaml                       as Yaml@@ -35,15 +35,14 @@ import           Path import           Path.IO import           Stack.BuildPlan+import           Stack.Config                    (getSnapshots,+                                                  makeConcreteResolver) import           Stack.Constants import           Stack.Solver import           Stack.Types-import           Stack.Types.Internal            ( HasTerminal, HasReExec-                                                 , HasLogLevel)-import           System.Directory                ( getDirectoryContents-                                                 , makeRelativeToCurrentDirectory)-import           Stack.Config                    ( getSnapshots-                                                 , makeConcreteResolver)+import           Stack.Types.Internal            (HasLogLevel, HasReExec,+                                                  HasTerminal)+import qualified System.FilePath                 as FP  -- | Generate stack.yaml initProject@@ -53,74 +52,133 @@        , HasTerminal env)     => Path Abs Dir     -> InitOpts+    -> Maybe AbstractResolver     -> m ()-initProject currDir initOpts = do+initProject currDir initOpts mresolver = do     let dest = currDir </> stackDotYaml-        dest' = toFilePath dest -    reldest <- liftIO $ makeRelativeToCurrentDirectory dest'+    reldest <- toFilePath `liftM` makeRelativeToCurrentDir dest -    exists <- fileExists dest+    exists <- doesFileExist dest     when (not (forceOverwrite initOpts) && exists) $ do         error ("Stack configuration file " <> reldest <>                " exists, use 'stack solver' to fix the existing config file or \                \'--force' to overwrite it.") +    dirs <- mapM (resolveDir' . T.unpack) (searchDirs initOpts)     let noPkgMsg =  "In order to init, you should have an existing .cabal \                     \file. Please try \"stack new\" instead."+        find  = findCabalFiles (includeSubDirs initOpts)+        dirs' = if null dirs then [currDir] else dirs+    cabalfps <- liftM concat $ mapM find dirs'+    (bundle, dupPkgs)  <- cabalPackagesCheck cabalfps noPkgMsg Nothing -        dupPkgFooter = "You have the following options:\n"-            <> "- Use '--ignore-subdirs' command line switch to ignore "-            <> "packages in subdirectories. You can init subdirectories as "-            <> "independent projects.\n"-            <> "- Put selected packages in the stack config file "-            <> "and then use 'stack solver' command to automatically resolve "-            <> "dependencies and update the config file."+    (r, flags, extraDeps, rbundle) <- getDefaultResolver dest initOpts+                                                         mresolver bundle -    cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir-    gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter+    let ignored = Map.difference bundle rbundle+        dupPkgMsg+            | (dupPkgs /= []) =+                "Warning: Some packages were found to have names conflicting \+                \with others and have been commented out in the \+                \packages section.\n"+            | otherwise = "" -    (r, flags, extraDeps) <--        getDefaultResolver dest (map parent cabalfps) gpds initOpts-    let p = Project-            { projectPackages = pkgs+        missingPkgMsg+            | (Map.size ignored > 0) =+                "Warning: Some packages were found to be incompatible with \+                \the resolver and have been left commented out in the \+                \packages section.\n"+            | otherwise = ""++        extraDepMsg+            | (Map.size extraDeps > 0) =+                "Warning: Specified resolver could not satisfy all \+                \dependencies. Some external packages have been added \+                \as dependencies.\n"+            | otherwise = ""++        makeUserMsg msgs =+            let msg = concat msgs+            in if msg /= "" then+                  msg <> "You can suppress this message by removing it from \+                         \stack.yaml\n"+                 else ""++        userMsg = makeUserMsg [dupPkgMsg, missingPkgMsg, extraDepMsg]++        gpds = Map.elems $ fmap snd rbundle+        p = Project+            { projectUserMsg = if userMsg == "" then Nothing else Just userMsg+            , projectPackages = pkgs             , projectExtraDeps = extraDeps             , projectFlags = removeSrcPkgDefaultFlags gpds flags             , projectResolver = r             , projectCompiler = Nothing             , projectExtraPackageDBs = []             }-        pkgs = map toPkg cabalfps-        toPkg fp = PackageEntry++        makeRelDir dir =+            case stripDir currDir dir of+                Nothing+                    | currDir == dir -> "."+                    | otherwise -> assert False $ toFilePath dir+                Just rel -> toFilePath rel++        makeRel = fmap toFilePath . makeRelativeToCurrentDir++        pkgs = map toPkg $ Map.elems (fmap (parent . fst) rbundle)+        toPkg dir = PackageEntry             { peValidWanted = Nothing             , peExtraDepMaybe = Nothing-            , peLocation = PLFilePath $-                case stripDir currDir $ parent fp of-                    Nothing-                        | currDir == parent fp -> "."-                        | otherwise -> assert False $ toFilePath $ parent fp-                    Just rel -> toFilePath rel+            , peLocation = PLFilePath $ makeRelDir dir             , peSubdirs = []             }+        indent t = T.unlines $ fmap ("    " <>) (T.lines t)      $logInfo $ "Initialising configuration using resolver: " <> resolverName r+    $logInfo $ "Total number of user packages considered: "+               <> (T.pack $ show $ (Map.size bundle + length dupPkgs))++    when (dupPkgs /= []) $ do+        $logWarn $ "Warning! Ignoring "+                   <> (T.pack $ show $ length dupPkgs)+                   <> " duplicate packages:"+        rels <- mapM makeRel dupPkgs+        $logWarn $ indent $ showItems rels++    when (Map.size ignored > 0) $ do+        $logWarn $ "Warning! Ignoring "+                   <> (T.pack $ show $ Map.size ignored)+                   <> " packages due to dependency conflicts:"+        rels <- mapM makeRel (Map.elems (fmap fst ignored))+        $logWarn $ indent $ showItems $ rels++    when (Map.size extraDeps > 0) $ do+        $logWarn $ "Warning! " <> (T.pack $ show $ Map.size extraDeps)+                   <> " external dependencies were added."     $logInfo $         (if exists then "Overwriting existing configuration file: "          else "Writing configuration to file: ")         <> T.pack reldest-    liftIO $ L.writeFile dest' $ B.toLazyByteString $ renderStackYaml p+    liftIO $ L.writeFile (toFilePath dest)+           $ B.toLazyByteString+           $ renderStackYaml p+               (Map.elems $ fmap (makeRelDir . parent . fst) ignored)+               (map (makeRelDir . parent) dupPkgs)     $logInfo "All done."  -- | Render a stack.yaml file with comments, see: -- https://github.com/commercialhaskell/stack/issues/226-renderStackYaml :: Project -> B.Builder-renderStackYaml p =+renderStackYaml :: Project -> [FilePath] -> [FilePath] -> B.Builder+renderStackYaml p ignoredPackages dupPackages =     case Yaml.toJSON p of         Yaml.Object o -> renderObject o         _ -> assert False $ B.byteString $ Yaml.encode p   where     renderObject o =-        B.byteString "# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html\n\n" <>+        B.byteString "# This file was automatically generated by stack init\n" <>+        B.byteString "# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/\n\n" <>         F.foldMap (goComment o) comments <>         goOthers (o `HM.difference` HM.fromList comments) <>         B.byteString@@ -139,21 +197,39 @@             \# compiler-check: newer-minor\n"      comments =-        [ ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)")+        [ ("user-message", "A message to be displayed to the user. Used when autogenerated config ignored some packages or added extra deps.")+        , ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)")         , ("packages", "Local packages, usually specified by relative directory name")         , ("extra-deps", "Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)")         , ("flags", "Override default flag values for local packages and extra-deps")         , ("extra-package-dbs", "Extra package databases containing global packages")         ] +    commentedPackages =+        let ignoredComment = "# The following packages have been ignored \+                \due to incompatibility with the resolver compiler or \+                \dependency conflicts with other packages"+            dupComment = "# The following packages have been ignored due \+                \to package name conflict with other packages"+        in commentPackages ignoredComment ignoredPackages+           <> commentPackages dupComment dupPackages++    commentPackages comment pkgs+        | pkgs /= [] =+            B.byteString (BC.pack $ comment ++ "\n")+            <> (B.byteString $ BC.pack $ concat+                 $ (map (\x -> "#- " ++ x ++ "\n") pkgs) ++ ["\n"])+        | otherwise = ""+     goComment o (name, comment) =         case HM.lookup name o of-            Nothing -> assert False mempty+            Nothing -> assert (name == "user-message") mempty             Just v ->                 B.byteString "# " <>                 B.byteString comment <>                 B.byteString "\n" <>                 B.byteString (Yaml.encode $ Yaml.object [(name, v)]) <>+                if (name == "packages") then commentedPackages else "" <>                 B.byteString "\n"      goOthers o@@ -161,9 +237,9 @@         | otherwise = assert False $ B.byteString $ Yaml.encode o  getSnapshots' :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)-              => m (Maybe Snapshots)+              => m Snapshots getSnapshots' =-    liftM Just getSnapshots `catchAny` \e -> do+    getSnapshots `catchAny` \e -> do         $logError $             "Unable to download snapshot list, and therefore could " <>             "not generate a stack.yaml file automatically"@@ -175,10 +251,10 @@         $logError ""         $logError "You can try again, or create your stack.yaml file by hand. See:"         $logError ""-        $logError "    http://docs.haskellstack.org/en/stable/yaml_configuration.html"+        $logError "    http://docs.haskellstack.org/en/stable/yaml_configuration/"         $logError ""         $logError $ "Exception was: " <> T.pack (show e)-        return Nothing+        error ""  -- | Get the default resolver value getDefaultResolver@@ -187,114 +263,188 @@        , HasHttpManager env , HasLogLevel env , HasReExec env        , HasTerminal env)     => Path Abs File   -- ^ stack.yaml-    -> [Path Abs Dir]  -- ^ cabal dirs-    -> [C.GenericPackageDescription] -- ^ cabal descriptions     -> InitOpts+    -> Maybe AbstractResolver+    -> Map PackageName (Path Abs File, C.GenericPackageDescription)+       -- ^ Src package name: cabal dir, cabal package description     -> m ( Resolver          , Map PackageName (Map FlagName Bool)-         , Map PackageName Version)-getDefaultResolver stackYaml cabalDirs gpds initOpts = do-    resolver <- getResolver (ioMethod initOpts)-    result   <- checkResolverSpec gpds Nothing resolver+         , Map PackageName Version+         , Map PackageName (Path Abs File, C.GenericPackageDescription))+       -- ^ ( Resolver+       --   , Flags for src packages and extra deps+       --   , Extra dependencies+       --   , Src packages actually considered)+getDefaultResolver stackYaml initOpts mresolver bundle =+    maybe selectSnapResolver makeConcreteResolver mresolver+      >>= getWorkingResolverPlan stackYaml initOpts bundle+    where+        -- TODO support selecting best across regular and custom snapshots+        selectSnapResolver = do+            let gpds = Map.elems (fmap snd bundle)+            snaps <- getSnapshots' >>= getRecommendedSnapshots+            (s, r) <- selectBestSnapshot gpds snaps+            case r of+                BuildPlanCheckFail {} | not (omitPackages initOpts)+                        -> throwM (NoMatchingSnapshot snaps)+                _ -> return $ ResolverSnapshot s -    case result of-        BuildPlanCheckOk f-> return (resolver, f, Map.empty)-        BuildPlanCheckPartial f e-            | needSolver resolver initOpts -> solve (resolver, f)-            | otherwise ->-                throwM $ ResolverPartial resolver (showDepErrors f e)-        BuildPlanCheckFail f e c ->-            throwM $ ResolverMismatch resolver (showCompilerErrors f e c)+getWorkingResolverPlan+    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m+       , MonadReader env m, HasConfig env , HasGHCVariant env+       , HasHttpManager env , HasLogLevel env , HasReExec env+       , HasTerminal env)+    => Path Abs File   -- ^ stack.yaml+    -> InitOpts+    -> Map PackageName (Path Abs File, C.GenericPackageDescription)+       -- ^ Src package name: cabal dir, cabal package description+    -> Resolver+    -> m ( Resolver+         , Map PackageName (Map FlagName Bool)+         , Map PackageName Version+         , Map PackageName (Path Abs File, C.GenericPackageDescription))+       -- ^ ( Resolver+       --   , Flags for src packages and extra deps+       --   , Extra dependencies+       --   , Src packages actually considered)+getWorkingResolverPlan stackYaml initOpts bundle resolver = do+    $logInfo $ "Selected resolver: " <> resolverName resolver+    go bundle+    where+        go info = do+            eres <- checkBundleResolver stackYaml initOpts info resolver+            -- if some packages failed try again using the rest+            case eres of+                Right (f, edeps)-> return (resolver, f, edeps, info)+                Left ignored+                    | Map.null available -> do+                        $logWarn "*** Could not find a working plan for any of \+                                 \the user packages.\nProceeding to create a \+                                 \config anyway."+                        return (resolver, Map.empty, Map.empty, Map.empty)+                    | otherwise -> do+                        when ((Map.size available) == (Map.size info)) $+                            error "Bug: No packages to ignore" +                        if length ignored > 1 then do+                          $logWarn "*** Ignoring packages:"+                          $logWarn $ indent $ showItems ignored+                        else+                          $logWarn $ "*** Ignoring package: "+                                 <> (T.pack $ packageNameString (head ignored))++                        go available+                    where+                      indent t   = T.unlines $ fmap ("    " <>) (T.lines t)+                      isAvailable k _ = not (k `elem` ignored)+                      available       = Map.filterWithKey isAvailable info++checkBundleResolver+    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m+       , MonadReader env m, HasConfig env , HasGHCVariant env+       , HasHttpManager env , HasLogLevel env , HasReExec env+       , HasTerminal env)+    => Path Abs File   -- ^ stack.yaml+    -> InitOpts+    -> Map PackageName (Path Abs File, C.GenericPackageDescription)+       -- ^ Src package name: cabal dir, cabal package description+    -> Resolver+    -> m (Either [PackageName] ( Map PackageName (Map FlagName Bool)+                               , Map PackageName Version))+checkBundleResolver stackYaml initOpts bundle resolver = do+    result <- checkResolverSpec gpds Nothing resolver+    case result of+        BuildPlanCheckOk f -> return $ Right (f, Map.empty)+        BuildPlanCheckPartial f _+            | needSolver resolver initOpts -> do+                $logWarn $ "*** Resolver " <> resolverName resolver+                            <> " will need external packages: "+                $logWarn $ indent $ T.pack $ show result+                solve f+            | otherwise -> throwM $ ResolverPartial resolver (show result)+        BuildPlanCheckFail _ e _+            | (omitPackages initOpts) -> do+                $logWarn $ "*** Resolver compiler mismatch: "+                           <> resolverName resolver+                $logWarn $ indent $ T.pack $ show result+                let failed = Map.unions (Map.elems (fmap deNeededBy e))+                return $ Left (Map.keys failed)+            | otherwise -> throwM $ ResolverMismatch resolver (show result)     where-      solve (res, f) = do-          let srcConstraints = mergeConstraints (gpdPackages gpds) f-          mresolver <- solveResolverSpec stackYaml cabalDirs-                                         (res, srcConstraints, Map.empty)-          case mresolver of-              Just (src, ext) -> do-                  return (res, fmap snd (Map.union src ext), fmap fst ext)-              Nothing-                  | forceOverwrite initOpts -> do-                      $logWarn "\nSolver could not arrive at a workable build \-                               \plan.\nProceeding to create a config with an \-                               \incomplete plan anyway..."-                      return (res, f, Map.empty)+      indent t    = T.unlines $ fmap ("    " <>) (T.lines t)+      gpds        = Map.elems (fmap snd bundle)+      solve flags = do+          let cabalDirs      = map parent (Map.elems (fmap fst bundle))+              srcConstraints = mergeConstraints (gpdPackages gpds) flags++          eresult <- solveResolverSpec stackYaml cabalDirs+                                       (resolver, srcConstraints, Map.empty)+          case eresult of+              Right (src, ext) ->+                  return $ Right (fmap snd (Map.union src ext), fmap fst ext)+              Left packages+                  | omitPackages initOpts, srcpkgs /= []-> do+                      pkg <- findOneIndependent srcpkgs flags+                      return $ Left [pkg]                   | otherwise -> throwM (SolverGiveUp giveUpMsg)+                  where srcpkgs = intersect (Map.keys bundle) packages +      -- among a list of packages find one on which none among the rest of the+      -- packages depend. This package is a good candidate to be removed from+      -- the list of packages when there is conflict in dependencies among this+      -- set of packages.+      findOneIndependent packages flags = do+          platform <- asks (configPlatform . getConfig)+          (compiler, _) <- getResolverConstraints stackYaml resolver+          let getGpd pkg = snd (fromJust (Map.lookup pkg bundle))+              getFlags pkg = fromJust (Map.lookup pkg flags)+              deps pkg = gpdPackageDeps (getGpd pkg) compiler platform+                                        (getFlags pkg)+              allDeps = concat $ map (Map.keys . deps) packages+              isIndependent pkg = not $ pkg `elem` allDeps++              -- prefer to reject packages in deeper directories+              path pkg = fst (fromJust (Map.lookup pkg bundle))+              pathlen = length . FP.splitPath . toFilePath . path+              maxPathlen = maximumBy (compare `on` pathlen)++          return $ maxPathlen (filter isIndependent packages)+       giveUpMsg = concat-          [ "    - Use '--ignore-subdirs' to skip packages in subdirectories.\n"-          , "    - Update external packages with 'stack update' and try again.\n"-          , "    - Use '--force' to create an initial "-          , toFilePath stackDotYaml <> ", tweak it and run 'stack solver':\n"-          , "        - Remove any unnecessary packages.\n"+          [ "    - Use '--omit-packages to exclude conflicting package(s).\n"+          , "    - Tweak the generated "+          , toFilePath stackDotYaml <> " and then run 'stack solver':\n"           , "        - Add any missing remote packages.\n"           , "        - Add extra dependencies to guide solver.\n"+          , "    - Update external packages with 'stack update' and try again.\n"           ] -      -- TODO support selecting best across regular and custom snapshots-      getResolver (MethodSnapshot snapPref)  = selectSnapResolver snapPref-      getResolver (MethodResolver aresolver) = makeConcreteResolver aresolver--      selectSnapResolver snapPref = do-          msnaps <- getSnapshots'-          snaps <- maybe (error "No snapshots to select from.")-                         (getRecommendedSnapshots snapPref)-                         msnaps-          selectBestSnapshot gpds snaps-            >>= maybe (throwM (NoMatchingSnapshot snaps))-                      (return . ResolverSnapshot)-       needSolver _ (InitOpts {useSolver = True}) = True       needSolver (ResolverCompiler _)  _ = True       needSolver _ _ = False  getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m)-                        => SnapPref-                        -> Snapshots+                        => Snapshots                         -> m [SnapName]-getRecommendedSnapshots pref snapshots = do-    -- Get the most recent LTS and Nightly in the snapshots directory and-    -- prefer them over anything else, since odds are high that something-    -- already exists for them.-    existing <--        liftM (sortBy (flip compare) . mapMaybe (parseSnapName . T.pack)) $-        snapshotsDir >>=-        liftIO . handleIO (const $ return [])-               . getDirectoryContents . toFilePath-    let isLTS LTS{} = True-        isLTS Nightly{} = False-        isNightly Nightly{} = True-        isNightly LTS{} = False--        names = nubOrd $ concat-            [ take 2 $ filter isLTS existing-            , take 2 $ filter isNightly existing-            , map (uncurry LTS)-                (take 2 $ reverse $ IntMap.toList $ snapshotsLts snapshots)-            , [Nightly $ snapshotsNightly snapshots]-            ]--        namesLTS = filter isLTS names-        namesNightly = filter isNightly names--    case pref of-        PrefNone -> return names-        PrefLTS -> return $ namesLTS ++ namesNightly-        PrefNightly -> return $ namesNightly ++ namesLTS+getRecommendedSnapshots snapshots = do+    -- in order - Latest LTS, Latest Nightly, all LTS most recent first+    return $ nubOrd $ concat+        [ map (uncurry LTS)+            (take 1 $ reverse $ IntMap.toList $ snapshotsLts snapshots)+        , [Nightly $ snapshotsNightly snapshots]+        , map (uncurry LTS)+            (drop 1 $ reverse $ IntMap.toList $ snapshotsLts snapshots)+        ]  data InitOpts = InitOpts-    { ioMethod       :: !Method-    -- ^ Use solver-    , useSolver :: Bool-    -- ^ Preferred snapshots+    { searchDirs     :: ![T.Text]+    -- ^ List of sub directories to search for .cabal files+    , useSolver      :: Bool+    -- ^ Use solver to determine required external dependencies+    , omitPackages   :: Bool+    -- ^ Exclude conflicting or incompatible user packages     , forceOverwrite :: Bool-    -- ^ Overwrite existing files+    -- ^ Overwrite existing stack.yaml     , includeSubDirs :: Bool     -- ^ If True, include all .cabal files found in any sub directories     }--data SnapPref = PrefNone | PrefLTS | PrefNightly---- | Method of initializing-data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver
src/Stack/New.hs view
@@ -42,6 +42,8 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT+import           Data.Time.Calendar+import           Data.Time.Clock import           Data.Typeable import           Network.HTTP.Client.Conduit hiding (path) import           Network.HTTP.Download@@ -75,13 +77,13 @@ -- | Create a new project with the given options. new     :: (HasConfig r, MonadReader r m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m, HasHttpManager r, Functor m, Applicative m)-    => NewOpts -> m (Path Abs Dir)-new opts = do-    pwd <- getWorkingDir+    => NewOpts -> Bool -> m (Path Abs Dir)+new opts forceOverwrite = do+    pwd <- getCurrentDir     absDir <- if bare then return pwd                       else do relDir <- parseRelDir (packageNameString project)                               liftM (pwd </>) (return relDir)-    exists <- dirExists absDir+    exists <- doesDirExist absDir     configTemplate <- configDefaultTemplate <$> asks getConfig     let template = fromMaybe defaultTemplateName $ asum [ cliOptionTemplate                                                         , configTemplate@@ -97,6 +99,7 @@                     (newOptsNonceParams opts)                     absDir                     templateText+            when (not forceOverwrite && bare) $ checkForOverwrite (M.keys files)             writeTemplateFiles files             runTemplateInits absDir             return absDir@@ -149,7 +152,7 @@     loadLocalFile path = do         $logDebug ("Opening local template: \"" <> T.pack (toFilePath path)                                                 <> "\"")-        exists <- fileExists path+        exists <- doesFileExist path         if exists             then liftIO (T.readFile (toFilePath path))             else throwM (FailedToLoadTemplate name (toFilePath path))@@ -176,9 +179,14 @@     -> m (Map (Path Abs File) LB.ByteString) applyTemplate project template nonceParams dir templateText = do     config <- asks getConfig-    let context = M.union (M.union nonceParams name) configParams+    currentYear <- do+      now <- liftIO getCurrentTime+      (year, _, _) <- return $ toGregorian . utctDay $ now+      return $ T.pack . show $ year+    let context = M.union (M.union nonceParams extraParams) configParams           where-            name = M.fromList [("name", packageNameText project)]+            extraParams = M.fromList [ ("name", packageNameText project)+                                     , ("year", currentYear) ]             configParams = configTemplateParams config     (applied,missingKeys) <-         runWriterT@@ -187,7 +195,7 @@                  templateText                  (mkStrContextM (contextFunction context)))     unless (S.null missingKeys)-         ($logInfo (T.pack (show (MissingParameters project template missingKeys (configUserConfigPath config)))))+         ($logInfo ("\n" <> T.pack (show (MissingParameters project template missingKeys (configUserConfigPath config))) <> "\n"))     files :: Map FilePath LB.ByteString <-         catch (execWriterT $                yield (T.encodeUtf8 (LT.toStrict applied)) $$@@ -223,6 +231,12 @@                 return MuNothing             Just value -> return (MuVariable value) +-- | Check if we're going to overwrite any existing files.+checkForOverwrite :: (MonadIO m, MonadThrow m) => [Path Abs File] -> m ()+checkForOverwrite files = do+    overwrites <- filterM doesFileExist files+    unless (null overwrites) $ throwM (AttemptedOverwrites overwrites)+ -- | Write files to the new project directory. writeTemplateFiles     :: MonadIO m@@ -231,7 +245,7 @@     forM_         (M.toList files)         (\(fp,bytes) ->-              do createTree (parent fp)+              do ensureDir (parent fp)                  liftIO (LB.writeFile (toFilePath fp) bytes))  -- | Run any initialization functions, such as Git.@@ -256,7 +270,7 @@     => m () listTemplates = do     templates <- getTemplates-    mapM_ ($logInfo . templateName) (S.toList templates)+    mapM_ (liftIO . T.putStrLn . templateName) (S.toList templates)  -- | Get the set of templates. getTemplates@@ -328,6 +342,7 @@     | AlreadyExists !(Path Abs Dir)     | MissingParameters !PackageName !TemplateName !(Set String) !(Path Abs File)     | InvalidTemplate !TemplateName !String+    | AttemptedOverwrites [Path Abs File]     deriving (Typeable)  instance Exception NewException@@ -386,3 +401,7 @@         "The template \"" <> T.unpack (templateName name) <>         "\" is invalid and could not be used. " <>         "The error was: \"" <> why <> "\""+    show (AttemptedOverwrites fps) =+        "The template would create the following files, but they already exist:\n" <>+        unlines (map (("  " ++) . toFilePath) fps) <>+        "Use --force to ignore this, and overwite these files."
src/Stack/Options.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings,RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}  module Stack.Options     (BuildCommand(..)@@ -26,32 +27,32 @@     ,globalOptsFromMonoid     ) where -import           Control.Monad.Logger (LogLevel(..))-import           Data.Char (isSpace, toLower)-import           Data.List (intercalate)-import           Data.List.Split (splitOn)-import qualified Data.Map as Map-import           Data.Map.Strict (Map)-import qualified Data.Map.Strict as M+import           Control.Monad.Logger              (LogLevel (..))+import           Data.Char                         (isSpace, toLower)+import           Data.List                         (intercalate)+import           Data.List.Split                   (splitOn)+import qualified Data.Map                          as Map+import           Data.Map.Strict                   (Map)+import qualified Data.Map.Strict                   as M import           Data.Maybe import           Data.Monoid-import qualified Data.Set as Set-import qualified Data.Text as T-import           Data.Text.Read (decimal)-import           Distribution.Version (anyVersion)+import qualified Data.Set                          as Set+import qualified Data.Text                         as T+import           Data.Text.Read                    (decimal)+import           Distribution.Version              (anyVersion) import           Options.Applicative import           Options.Applicative.Args import           Options.Applicative.Builder.Extra-import           Options.Applicative.Types (fromM, oneM, readerAsk)-import           Stack.Clean (CleanOpts(..))-import           Stack.Config (packagesParser)+import           Options.Applicative.Types         (fromM, oneM, readerAsk)+import           Stack.Clean                       (CleanOpts (..))+import           Stack.Config                      (packagesParser) import           Stack.ConfigCmd-import           Stack.Constants (stackProgName)-import           Stack.Coverage (HpcReportOpts(..))+import           Stack.Constants                   (stackProgName)+import           Stack.Coverage                    (HpcReportOpts (..)) import           Stack.Docker-import qualified Stack.Docker as Docker+import qualified Stack.Docker                      as Docker import           Stack.Dot-import           Stack.Ghci (GhciOpts(..))+import           Stack.Ghci                        (GhciOpts (..)) import           Stack.Init import           Stack.New import           Stack.Nix@@ -68,9 +69,12 @@     deriving (Eq)  -- | Allows adjust global options depending on their context+-- Note: This was being used to remove ambibuity between the local and global+-- implementation of stack init --resolver option. Now that stack init has no+-- local --resolver this is not being used anymore but the code is kept for any+-- similar future use cases. data GlobalOptsContext     = OuterGlobalOpts -- ^ Global options before subcommand name-    | InitCmdGlobalOpts -- ^ Global options following 'stack init'     | OtherCmdGlobalOpts -- ^ Global options following any other subcommand     deriving (Show, Eq) @@ -98,7 +102,7 @@                            ,boptsBenchmarkOpts =                                 bopts {beoAdditionalArgs =                                            beoAdditionalArgs bopts <>-                                           Just (unwords additionalArgs)}+                                           Just (" " <> unwords additionalArgs)}                            ,boptsTestOpts =                                 topts {toAdditionalArgs =                                            (toAdditionalArgs topts) <>@@ -106,13 +110,13 @@                   | otherwise = opts                   where bopts = boptsBenchmarkOpts opts                         topts = boptsTestOpts opts-                        additionalArgs = [" +RTS ", trac, prof]+                        additionalArgs = "+RTS" : catMaybes [trac, prof, Just "-RTS"]                         trac = if tracing-                                  then " -xc "-                                  else ""+                                  then Just "-xc"+                                  else Nothing                         prof = if profiling-                                  then " -p "-                                  else ""+                                  then Just "-p"+                                  else Nothing         profile =             flag False True              ( long "profile"@@ -269,18 +273,22 @@  -- | Command-line parser for the clean command. cleanOptsParser :: Parser CleanOpts-cleanOptsParser = CleanOpts <$> packages+cleanOptsParser = CleanTargets <$> packages <|> CleanFull <$> doFullClean   where     packages =         many             (packageNameArgument                  (metavar "PACKAGE" <>                   help "If none specified, clean all local packages"))+    doFullClean =+        switch+            (long "full" <>+             help "Remove whole the work dir, default is .stack-work")  -- | Command-line arguments parser for configuration. configOptsParser :: Bool -> Parser ConfigMonoid configOptsParser hide0 =-    (\workDir dockerOpts nixOpts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage -> mempty+    (\workDir dockerOpts nixOpts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage allowDifferentUser -> mempty         { configMonoidWorkDir = workDir         , configMonoidDockerOpts = dockerOpts         , configMonoidNixOpts = nixOpts@@ -296,6 +304,7 @@         , configMonoidSkipMsys = skipMsys         , configMonoidLocalBinPath = localBin         , configMonoidModifyCodePage = modifyCodePage+        , configMonoidAllowDifferentUser = allowDifferentUser         })     <$> optional (strOption             ( long "work-dir"@@ -363,6 +372,11 @@             "modify-code-page"             "setting the codepage to support UTF-8 (Windows only)"             hide+    <*> maybeBoolFlags+            "allow-different-user"+            ("permission for users other than the owner of the stack root " +++                "directory to use a stack installation (POSIX only)")+            hide   where hide = hideMods hide0  nixOptsParser :: Bool -> Parser NixOptsMonoid@@ -576,6 +590,7 @@                             help "Specify which target should contain the main \                                  \module to load, such as for an executable for \                                  \test suite or benchmark."))+             <*> switch (long "load-local-deps" <> help "Load all local dependencies of your targets")              <*> switch (long "skip-intermediate-deps" <> help "Skip loading intermediate target dependencies")              <*> boolFlags True "package-hiding" "package hiding" idm              <*> buildOptsParser Build@@ -637,11 +652,7 @@     optional (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*>     logLevelOptsParser hide0 defLogLevel <*>     configOptsParser hide0 <*>-    (if kind == InitCmdGlobalOpts-     -- The 'stack init' command has its own '--resolver' option, and having a global-     -- one causes ambiguity, so disable it.-     then pure Nothing-     else optional (abstractResolverOptsParser hide0)) <*>+    optional (abstractResolverOptsParser hide0) <*>     optional (compilerOptsParser hide0) <*>     maybeBoolFlags         "terminal"@@ -670,32 +681,22 @@  initOptsParser :: Parser InitOpts initOptsParser =-    InitOpts <$> method <*> solver <*> overwrite <*> fmap not ignoreSubDirs+    InitOpts <$> searchDirs+             <*> solver <*> omitPackages+             <*> overwrite <*> fmap not ignoreSubDirs   where+    searchDirs =+      many (textArgument+              (metavar "DIRS" <>+               help "Directories to include, default is current directory."))     ignoreSubDirs = switch (long "ignore-subdirs" <>                            help "Do not search for .cabal files in sub directories")     overwrite = switch (long "force" <>-                       help "Force overwriting an existing stack.yaml or \-                            \creating a stack.yaml with incomplete config.")+                       help "Force overwriting an existing stack.yaml")+    omitPackages = switch (long "omit-packages" <>+                           help "Exclude conflicting or incompatible user packages")     solver = switch (long "solver" <>              help "Use a dependency solver to determine extra dependencies")--    method = (MethodResolver <$> resolver)-         <|> (MethodSnapshot <$> snapPref)--    snapPref =-        flag' PrefLTS-            (long "prefer-lts" <>-             help "Prefer LTS snapshots over Nightly snapshots") <|>-        flag' PrefNightly-            (long "prefer-nightly" <>-             help "Prefer Nightly snapshots over LTS snapshots") <|>-        pure PrefNone--    resolver = option readAbstractResolver-        (long "resolver" <>-         metavar "RESOLVER" <>-         help "Use the specified resolver")  -- | Parser for a logging level. logLevelOptsParser :: Bool -> Maybe LogLevel -> Parser (Maybe LogLevel)
src/Stack/Package.hs view
@@ -20,7 +20,7 @@   ,readPackageUnresolved   ,readPackageUnresolvedBS   ,resolvePackage-  ,getCabalFileName+  ,findOrGenerateCabalFile   ,Package(..)   ,GetPackageFiles(..)   ,GetPackageOpts(..)@@ -30,7 +30,6 @@   ,resolvePackageDescription   ,packageToolDependencies   ,packageDependencies-  ,packageIdentifier   ,autogenDir   ,checkCabalFileName   ,printCabalFileWarning@@ -50,7 +49,6 @@ import           Control.Monad.Reader import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8-import           Data.Either import           Data.Function import           Data.List import           Data.List.Extra (nubOrd)@@ -83,23 +81,18 @@ import           Path as FL import           Path.Extra import           Path.Find-import           Path.IO+import           Path.IO hiding (findFiles) import           Prelude import           Safe (headDef, tailSafe) import           Stack.Build.Installed import           Stack.Constants import           Stack.Types-import qualified Stack.Types.PackageIdentifier-import           System.Directory (doesFileExist, getDirectoryContents)+import qualified System.Directory as D import           System.FilePath (splitExtensions, replaceExtension) import qualified System.FilePath as FilePath import           System.IO.Error--packageIdentifier :: Package -> Stack.Types.PackageIdentifier.PackageIdentifier-packageIdentifier pkg =-    Stack.Types.PackageIdentifier.PackageIdentifier-        (packageName pkg)-        (packageVersion pkg)+import qualified Hpack+import qualified Hpack.Config as Hpack  -- | Read the raw, unresolved package information. readPackageUnresolved :: (MonadIO m, MonadThrow m)@@ -150,7 +143,7 @@   -> Path Abs Dir   -> m (GenericPackageDescription, PackageDescription) readPackageDescriptionDir config pkgDir = do-    cabalfp <- getCabalFileName pkgDir+    cabalfp <- findOrGenerateCabalFile pkgDir     gdesc   <- liftM snd (readPackageUnresolved cabalfp)     return (gdesc, resolvePackageDescription config gdesc) @@ -222,12 +215,23 @@   where     pkgFiles = GetPackageFiles $         \cabalfp ->-             do distDir <- distDirFromDir (parent cabalfp)+             do let pkgDir = parent cabalfp+                distDir <- distDirFromDir pkgDir                 (componentModules,componentFiles,dataFiles',warnings) <-                     runReaderT                         (packageDescModulesAndFiles pkg)                         (cabalfp, buildDir distDir)-                return (componentModules, componentFiles, S.insert cabalfp dataFiles', warnings)+                buildFiles <- liftM (S.insert cabalfp) $+                    if buildType pkg `elem` [Nothing, Just Custom]+                    then do+                        let setupHsPath = pkgDir </> $(mkRelFile "Setup.hs")+                            setupLhsPath = pkgDir </> $(mkRelFile "Setup.lhs")+                        setupHsExists <- doesFileExist setupHsPath+                        if setupHsExists then return (S.singleton setupHsPath) else do+                            setupLhsExists <- doesFileExist setupLhsPath+                            if setupLhsExists then return (S.singleton setupLhsPath) else return S.empty+                    else return S.empty+                return (componentModules, componentFiles, buildFiles <> dataFiles', warnings)     pkgId = package (packageDescription gpkg)     name = fromCabalPackageName (pkgName pkgId)     pkg = resolvePackageDescription packageConfig gpkg@@ -249,7 +253,7 @@ generatePkgDescOpts sourceMap installedMap omitPkgs addPkgs cabalfp pkg componentPaths = do     distDir <- distDirFromDir cabalDir     let cabalMacros = autogenDir distDir </> $(mkRelFile "cabal_macros.h")-    exists <- fileExists cabalMacros+    exists <- doesFileExist cabalMacros     let mcabalMacros =             if exists                 then Just cabalMacros@@ -587,7 +591,7 @@                 ++ " If a wildcard is used it must be with an file extension."   Just (NoGlob filepath') -> return [filepath']   Just (FileGlob dir' ext) -> do-    files <- getDirectoryContents (dir FilePath.</> dir')+    files <- D.getDirectoryContents (dir FilePath.</> dir')     case   [ dir' FilePath.</> file            | file <- files            , let (name, ext') = splitExtensions file@@ -598,7 +602,7 @@  -- | Get all files referenced by the benchmark. benchmarkFiles-    :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)+    :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m)     => Benchmark -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) benchmarkFiles bench = do     dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)@@ -621,7 +625,7 @@  -- | Get all files referenced by the test. testFiles-    :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)+    :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m)     => TestSuite     -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) testFiles test = do@@ -646,7 +650,7 @@  -- | Get all files referenced by the executable. executableFiles-    :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)+    :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m)     => Executable     -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) executableFiles exe = do@@ -666,7 +670,7 @@  -- | Get all files referenced by the library. libraryFiles-    :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)+    :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m)     => Library -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) libraryFiles lib = do     dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)@@ -686,7 +690,7 @@     build = libBuildInfo lib  -- | Get all C sources and extra source files in a build.-buildOtherSources :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m)+buildOtherSources :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader (Path Abs File, Path Abs Dir) m)            => BuildInfo -> m (Set DotCabalPath) buildOtherSources build =     do csources <- liftM@@ -894,7 +898,7 @@                         FilePath.replaceExtension                             (toFilePath (dumpHIDir </> fileRel))                             ".dump-hi"-                dumpHIExists <- liftIO $ doesFileExist dumpHIPath+                dumpHIExists <- liftIO $ D.doesFileExist dumpHIPath                 if dumpHIExists                     then parseDumpHI dumpHIPath                     else return (S.empty, [])@@ -977,29 +981,29 @@             DotCabalCFile{} -> DotCabalCFilePath     paths_pkg pkg = "Paths_" ++ packageNameString pkg     makeNameCandidates =-        liftM (nubOrd . rights . concat) (mapM makeDirCandidates dirs)+        liftM (nubOrd . concat) (mapM makeDirCandidates dirs)     makeDirCandidates :: Path Abs Dir-                      -> IO [Either ResolveException (Path Abs File)]+                      -> IO [Path Abs File]     makeDirCandidates dir =         case name of-            DotCabalMain fp -> liftM return (try (resolveFile' dir fp))-            DotCabalFile fp -> liftM return (try (resolveFile' dir fp))-            DotCabalCFile fp -> liftM return (try (resolveFile' dir fp))+            DotCabalMain fp -> resolveCandidate dir fp+            DotCabalFile fp -> resolveCandidate dir fp+            DotCabalCFile fp -> resolveCandidate dir fp             DotCabalModule mn ->-                mapM+                liftM concat+                $ mapM                   ((\ ext ->-                     try (resolveFile' dir (Cabal.toFilePath mn ++ "." ++ ext)))+                     resolveCandidate dir (Cabal.toFilePath mn ++ "." ++ ext))                    . T.unpack)                    exts-    resolveFile'+    resolveCandidate         :: (MonadIO m, MonadThrow m)-        => Path Abs Dir -> FilePath.FilePath -> m (Path Abs File)-    resolveFile' x y = do+        => Path Abs Dir -> FilePath.FilePath -> m [Path Abs File]+    resolveCandidate x y = do+        -- The standard canonicalizePath does not work for this case         p <- parseCollapsedAbsFile (toFilePath x FilePath.</> y)-        exists <- fileExists p-        if exists-            then return p-            else throwM $ ResolveFileFailed x y (toFilePath p)+        exists <- doesFileExist p+        return $ if exists then [p] else []  -- | Warn the user that multiple candidates are available for an -- entry, but that we picked one anyway and continued.@@ -1044,7 +1048,7 @@     makePossibilities name =         mapM             (\dir ->-                  do (_,files) <- listDirectory dir+                  do (_,files) <- listDir dir                      return                          (map                               filename@@ -1058,11 +1062,15 @@ -- -- If no .cabal file is present, or more than one is present, an exception is -- thrown via 'throwM'.-getCabalFileName+--+-- If the directory contains a file named package.yaml, hpack is used to+-- generate a .cabal file from it.+findOrGenerateCabalFile     :: (MonadThrow m, MonadIO m)     => Path Abs Dir -- ^ package directory     -> m (Path Abs File)-getCabalFileName pkgDir = do+findOrGenerateCabalFile pkgDir = do+    liftIO $ hpack pkgDir     files <- liftIO $ findFiles         pkgDir         (flip hasExtension "cabal" . FL.toFilePath)@@ -1073,6 +1081,13 @@         _:_ -> throwM $ PackageMultipleCabalFilesFound pkgDir files   where hasExtension fp x = FilePath.takeExtension fp == "." ++ x +-- | Generate .cabal file from package.yaml, if necessary.+hpack :: Path Abs Dir -> IO ()+hpack pkgDir = do+    exists <- doesFileExist (pkgDir </> $(mkRelFile Hpack.packageConfig))+    when exists $ do+        Hpack.hpack (toFilePath pkgDir) True+ -- | Path for the package's build log. buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m)              => Package -> Maybe String -> m (Path Abs File)@@ -1085,13 +1100,13 @@   return $ stack </> $(mkRelDir "logs") </> fp  -- Internal helper to define resolveFileOrWarn and resolveDirOrWarn-resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m)+resolveOrWarn :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)               => Text               -> (Path Abs Dir -> String -> m (Maybe a))               -> FilePath.FilePath               -> m (Maybe a) resolveOrWarn subject resolver path =-  do cwd <- getWorkingDir+  do cwd <- getCurrentDir      file <- asks fst      dir <- asks (parent . fst)      result <- resolver dir path@@ -1104,17 +1119,19 @@  -- | Resolve the file, if it can't be resolved, warn for the user -- (purely to be helpful).-resolveFileOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m)+resolveFileOrWarn :: (MonadCatch m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m)                   => FilePath.FilePath                   -> m (Maybe (Path Abs File))-resolveFileOrWarn = resolveOrWarn "File" resolveFileMaybe+resolveFileOrWarn = resolveOrWarn "File" f+  where f p x = forgivingAbsence (resolveFile p x)  -- | Resolve the directory, if it can't be resolved, warn for the user -- (purely to be helpful).-resolveDirOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m)+resolveDirOrWarn :: (MonadCatch m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m)                  => FilePath.FilePath                  -> m (Maybe (Path Abs Dir))-resolveDirOrWarn = resolveOrWarn "Directory" resolveDirMaybe+resolveDirOrWarn = resolveOrWarn "Directory" f+  where f p x = forgivingAbsence (resolveDir p x)  -- | Extract the @PackageIdentifier@ given an exploded haskell package -- path.
src/Stack/PackageDump.hs view
@@ -50,7 +50,7 @@ import           Data.Typeable (Typeable) import           GHC.Generics (Generic) import           Path-import           Path.IO (createTree)+import           Path.IO (ensureDir) import           Path.Extra (toFilePathNoTrailingSep) import           Prelude -- Fix AMP warning import           Stack.GhcPkg@@ -135,7 +135,7 @@ -- | Save a @InstalledCache@ to disk saveInstalledCache :: MonadIO m => Path Abs File -> InstalledCache -> m () saveInstalledCache path (InstalledCache ref) = liftIO $ do-    createTree (parent path)+    ensureDir (parent path)     readIORef ref >>= taggedEncodeFile path  -- | Prune a list of possible packages down to those whose dependencies are met.
src/Stack/PackageIndex.hs view
@@ -53,7 +53,6 @@  import           Data.Typeable (Typeable) - import           Network.HTTP.Download import           Path                                  (mkRelDir, parent,                                                         parseRelDir, toFilePath,@@ -177,20 +176,20 @@  -- | Require that an index be present, updating if it isn't. requireIndex :: (MonadIO m,MonadLogger m-                ,MonadThrow m,MonadReader env m,HasHttpManager env+                ,MonadReader env m,HasHttpManager env                 ,HasConfig env,MonadBaseControl IO m,MonadCatch m)              => EnvOverride              -> PackageIndex              -> m () requireIndex menv index = do     tarFile <- configPackageIndex $ indexName index-    exists <- fileExists tarFile+    exists <- doesFileExist tarFile     unless exists $ updateIndex menv index  -- | Update all of the package indices updateAllIndices     :: (MonadIO m,MonadLogger m-       ,MonadThrow m,MonadReader env m,HasHttpManager env+       ,MonadReader env m,HasHttpManager env        ,HasConfig env,MonadBaseControl IO m, MonadCatch m)     => EnvOverride     -> m ()@@ -199,7 +198,7 @@  -- | Update the index tarball updateIndex :: (MonadIO m,MonadLogger m-               ,MonadThrow m,MonadReader env m,HasHttpManager env+               ,MonadReader env m,HasHttpManager env                ,HasConfig env,MonadBaseControl IO m, MonadCatch m)             => EnvOverride             -> PackageIndex@@ -216,7 +215,7 @@         (False, ILGit url) -> logUpdate url >> throwM (GitNotAvailable name)  -- | Update the index Git repo and the index tarball-updateIndexGit :: (MonadIO m,MonadLogger m,MonadThrow m,MonadReader env m,HasConfig env,MonadBaseControl IO m, MonadCatch m)+updateIndexGit :: (MonadIO m,MonadLogger m,MonadReader env m,HasConfig env,MonadBaseControl IO m, MonadCatch m)                => EnvOverride                -> IndexName                -> PackageIndex@@ -225,7 +224,7 @@ updateIndexGit menv indexName' index gitUrl = do      tarFile <- configPackageIndex indexName'      let idxPath = parent tarFile-     createTree idxPath+     ensureDir idxPath      do             repoName <- parseRelDir $ takeBaseName $ T.unpack gitUrl             let cloneArgs =@@ -241,7 +240,7 @@                   sDir </>                   $(mkRelDir "git-update")                 acfDir = suDir </> repoName-            repoExists <- dirExists acfDir+            repoExists <- doesDirExist acfDir             unless repoExists                    (readInNull suDir "git" menv cloneArgs Nothing)             $logSticky "Fetching package index ..."@@ -249,12 +248,12 @@               -- we failed, so wipe the directory and try again, see #1418               $logWarn (T.pack (show ex))               $logStickyDone "Failed to fetch package index, retrying."-              removeTree acfDir+              removeDirRecur acfDir               readInNull suDir "git" menv cloneArgs Nothing               $logSticky "Fetching package index ..."               readInNull acfDir "git" menv ["fetch","--tags","--depth=1"] Nothing             $logStickyDone "Fetched package index."-            removeFileIfExists tarFile+            ignoringAbsence (removeFile tarFile)             when (indexGpgVerify index)                  (readInNull acfDir                              "git"@@ -297,7 +296,7 @@     toUnpack <-         if wasDownloaded             then return True-            else liftM not $ fileExists tar+            else not `liftM` doesFileExist tar      when toUnpack $ do         let tmp = toFilePath tar <.> "tmp"
src/Stack/SDist.hs view
@@ -46,7 +46,7 @@ import           Distribution.Version.Extra import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path-import           Path.IO+import           Path.IO hiding (getModificationTime, getPermissions) import           Prelude -- Fix redundant import warnings import           Stack.Build (mkBaseConfigOpts) import           Stack.Build.Execute@@ -57,8 +57,7 @@ import           Stack.Package import           Stack.Types import           Stack.Types.Internal-import           System.Directory (getModificationTime, getPermissions, Permissions(..))-import           System.IO.Temp (withSystemTempDirectory)+import           System.Directory (getModificationTime, getPermissions) import qualified System.FilePath as FP  -- | Special exception to throw when you want to fail because of bad results@@ -151,7 +150,6 @@                       Just (_, installed) -> Just (installedVersion installed)                       Nothing -> Nothing -     addUpper version = intersectVersionRanges         (earlierVersion $ toCabalVersion $ nextMajorVersion version)     addLower version = intersectVersionRanges@@ -176,7 +174,7 @@ -- use-cases. readLocalPackage :: M env m => Path Abs Dir -> m LocalPackage readLocalPackage pkgDir = do-    cabalfp <- getCabalFileName pkgDir+    cabalfp <- findOrGenerateCabalFile pkgDir     name    <- parsePackageNameFromFilePath cabalfp     config  <- getPackageConfig defaultBuildOpts name     (warnings,package) <- readPackage config cabalfp@@ -201,7 +199,7 @@ -- | Returns a newline-separate list of paths, and the absolute path to the .cabal file. getSDistFileList :: M env m => LocalPackage -> m (String, Path Abs File) getSDistFileList lp =-    withCanonicalizedSystemTempDirectory (stackProgName <> "-sdist") $ \tmpdir -> do+    withSystemTempDir (stackProgName <> "-sdist") $ \tmpdir -> do         menv <- getMinimalEnvOverride         let bopts = defaultBuildOpts         baseConfigOpts <- mkBaseConfigOpts bopts@@ -269,7 +267,7 @@     pkgDir  <- (pkgDir' </>) `liftM`         (parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball)     --               ^ drop ".tar"     ^ drop ".gz"-    cabalfp <- getCabalFileName pkgDir+    cabalfp <- findOrGenerateCabalFile pkgDir     name    <- parsePackageNameFromFilePath cabalfp     config  <- getPackageConfig defaultBuildOpts name     (gdesc, pkgDesc) <- readPackageDescriptionDir config pkgDir@@ -296,8 +294,7 @@   => String       -- ^ Tarball name   -> L.ByteString -- ^ Tarball contents as a byte string   -> m ()-checkSDistTarball' name bytes = withSystemTempDirectory "stack" $ \tdir -> do-    tpath   <- parseAbsDir tdir+checkSDistTarball' name bytes = withSystemTempDir "stack" $ \tpath -> do     npath   <- (tpath </>) `liftM` parseRelFile name     liftIO $ L.writeFile (toFilePath npath) bytes     checkSDistTarball npath@@ -306,8 +303,7 @@   => Path Abs File         -- ^ Location of tarball   -> (Path Abs Dir -> m a) -- ^ Perform actions given dir with tarball contents   -> m a-withTempTarGzContents apath f = withSystemTempDirectory "stack" $ \tdir -> do-    tpath   <- parseAbsDir tdir+withTempTarGzContents apath f = withSystemTempDir "stack" $ \tpath -> do     archive <- liftIO $ L.readFile (toFilePath apath)     liftIO . Tar.unpack (toFilePath tpath) . Tar.read . GZip.decompress $ archive     f tpath
src/Stack/Setup.hs view
@@ -68,7 +68,7 @@ import           Network.HTTP.Download.Verified import           Path import           Path.Extra (toFilePathNoTrailingSep)-import           Path.IO+import           Path.IO hiding (findExecutable) import qualified Paths_stack as Meta import           Prelude hiding (concat, elem, any) -- Fix AMP warning import           Safe (readMay)@@ -158,7 +158,7 @@         [ "The GHC located at "         , toFilePath ghc         , " failed to compile a sanity check. Please see:\n\n"-        , "    http://docs.haskellstack.org/en/stable/install_and_upgrade.html\n\n"+        , "    http://docs.haskellstack.org/en/stable/install_and_upgrade/\n\n"         , "for more information. Exception was:\n"         , show e         ]@@ -446,7 +446,7 @@         stackVersion = fromCabalVersion Meta.version         tool = Tool (PackageIdentifier $(mkPackageName "stack") stackVersion)     stackExePath <- (</> $(mkRelFile "stack")) <$> installDir programsPath tool-    stackExeExists <- fileExists stackExePath+    stackExeExists <- doesFileExist stackExePath     unless stackExeExists $         do            $logInfo $ mconcat ["Downloading Docker-compatible ", T.pack stackProgName, " executable"]@@ -492,7 +492,7 @@             , T.pack $ versionString newest             , ". I'm not upgrading Cabal."             ]-        else withCanonicalizedSystemTempDirectory "stack-cabal-upgrade" $ \tmpdir -> do+        else withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> do             $logInfo $ T.concat                 [ "Installing Cabal-"                 , T.pack $ versionString newest@@ -784,7 +784,7 @@     $logDebug $ "make: " <> T.pack makeTool     $logDebug $ "tar: " <> T.pack tarTool -    withCanonicalizedSystemTempDirectory "stack-setup" $ \root -> do+    withSystemTempDir "stack-setup" $ \root -> do         dir <-             liftM (root </>) $             parseRelDir $@@ -847,7 +847,7 @@             $logDebug $ "ziptool: " <> T.pack zipTool             $logDebug $ "tar: " <> T.pack tarTool             return $ do-                removeTreeIfExists unpackDir+                ignoringAbsence (removeDirRecur unpackDir)                 readInNull destDir tarTool menv ["xf", toFilePath archiveFile] Nothing                 innerDir <- expectSingleUnpackedDir archiveFile destDir                 renameDir innerDir unpackDir@@ -859,7 +859,7 @@     $logSticky "Setting up GHCJS build environment"     let stackYaml = unpackDir </> $(mkRelFile "stack.yaml")         destBinDir = destDir </> $(mkRelDir "bin")-    createTree destBinDir+    ensureDir destBinDir     envConfig <- loadGhcjsEnvConfig stackYaml destBinDir      -- On windows we need to copy options files out of the install dir.  Argh!@@ -875,10 +875,10 @@         build (\_ -> return ()) Nothing defaultBuildOpts { boptsInstallExes = True }     -- Copy over *.options files needed on windows.     forM_ mwindowsInstallDir $ \dir -> do-        (_, files) <- listDirectory (dir </> $(mkRelDir "bin"))+        (_, files) <- listDir (dir </> $(mkRelDir "bin"))         forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do             let dest = destDir </> $(mkRelDir "bin") </> filename optionsFile-            removeFileIfExists dest+            ignoringAbsence (removeFile dest)             copyFile optionsFile dest     $logStickyDone "Installed GHCJS." @@ -895,7 +895,7 @@         checkDependencies $         (,) <$> checkDependency "gzip" <*> checkDependency "tar"     menv <- getMinimalEnvOverride-    createTree destDir+    ensureDir destDir     readInNull         destDir         tarTool@@ -924,14 +924,14 @@                 -- https://github.com/commercialhaskell/stack/issues/749#issuecomment-147382783                 -- This only affects the case where GHCJS has been                 -- installed with an older version and not yet booted.-                stackYamlExists <- fileExists stackYaml+                stackYamlExists <- doesFileExist stackYaml                 actualStackYaml <- if stackYamlExists then return stackYaml                     else case cv of                         GhcjsVersion version _ ->                             liftM ((destDir </> $(mkRelDir "src")) </>) $                             parseRelFile $ "ghcjs-" ++ versionString version ++ "/stack.yaml"                         _ -> fail "ensureGhcjsBooted invoked on non GhcjsVersion"-                actualStackYamlExists <- fileExists actualStackYaml+                actualStackYamlExists <- doesFileExist actualStackYaml                 unless actualStackYamlExists $                     fail "Couldn't find GHCJS stack.yaml in old or new location."                 bootGhcjs actualStackYaml destDir@@ -1103,14 +1103,14 @@             Just x -> parseAbsFile $ T.unpack x     run7z <- setup7z si     let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp"-    createTree (parent destDir)-    withCanonicalizedTempDirectory (toFilePath $ parent destDir) tmpName $ \tmpDir -> do+    ensureDir (parent destDir)+    withTempDir (parent destDir) tmpName $ \tmpDir -> do+        ignoringAbsence (removeDirRecur destDir)+        run7z (parent archiveFile) archiveFile+        run7z tmpDir tarFile         absSrcDir <- case msrcDir of             Just srcDir -> return $ tmpDir </> srcDir             Nothing -> expectSingleUnpackedDir archiveFile tmpDir-        removeTreeIfExists destDir-        run7z (parent archiveFile) archiveFile-        run7z tmpDir tarFile         removeFile tarFile `catchIO` \e ->             $logWarn (T.concat                 [ "Exception when removing "@@ -1122,7 +1122,7 @@  expectSingleUnpackedDir :: (MonadIO m, MonadThrow m) => Path Abs File -> Path Abs Dir -> m (Path Abs Dir) expectSingleUnpackedDir archiveFile destDir = do-    contents <- listDirectory destDir+    contents <- listDir destDir     case contents of         ([dir], []) -> return dir         _ -> error $ "Expected a single directory within unpacked " ++ toFilePath archiveFile@@ -1277,13 +1277,12 @@           else put (lastTime,    acc')         go - -- | Perform a basic sanity check of GHC sanityCheck :: (MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m)             => EnvOverride             -> WhichCompiler             -> m ()-sanityCheck menv wc = withCanonicalizedSystemTempDirectory "stack-sanity-check" $ \dir -> do+sanityCheck menv wc = withSystemTempDir "stack-sanity-check" $ \dir -> do     let fp = toFilePath $ dir </> $(mkRelFile "Main.hs")     liftIO $ writeFile fp $ unlines         [ "import Distribution.Simple" -- ensure Cabal library is present
src/Stack/Setup/Installed.hs view
@@ -63,20 +63,20 @@     fpRel <- parseRelFile $ toolString tool ++ ".installed"     liftIO $ writeFile (toFilePath $ programsPath </> fpRel) "installed" -unmarkInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)+unmarkInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadCatch m)                 => Path Abs Dir                 -> Tool                 -> m () unmarkInstalled programsPath tool = do     fpRel <- parseRelFile $ toolString tool ++ ".installed"-    removeFileIfExists $ programsPath </> fpRel+    ignoringAbsence (removeFile $ programsPath </> fpRel)  listInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)               => Path Abs Dir               -> m [Tool] listInstalled programsPath = do-    createTree programsPath-    (_, files) <- listDirectory programsPath+    ensureDir programsPath+    (_, files) <- listDir programsPath     return $ mapMaybe toTool files   where     toTool fp = do
src/Stack/Sig/Sign.hs view
@@ -133,6 +133,6 @@     workDir <- getWorkDir     let tempDir = projectRoot </> workDir </> $(mkRelDir "tmp") </> uuidPath     bracket-        (createTree tempDir)-        (const (removeTree tempDir))+        (ensureDir tempDir)+        (const (removeDirRecur tempDir))         (const (f tempDir))
src/Stack/Solver.hs view
@@ -6,6 +6,7 @@     ( checkResolverSpec     , cabalPackagesCheck     , findCabalFiles+    , getResolverConstraints     , mergeConstraints     , solveExtraDeps     , solveResolverSpec@@ -22,11 +23,14 @@ import           Data.Aeson.Extended         (object, (.=), toJSON, logJSONWarnings) import qualified Data.ByteString             as S import           Data.Either+import           Data.Function               (on) import qualified Data.HashMap.Strict         as HashMap-import           Data.List                   ((\\), isSuffixOf, intercalate)+import           Data.List                   ( (\\), isSuffixOf, intercalate+                                             , minimumBy) import           Data.List.Extra             (groupSortOn) import           Data.Map                    (Map) import qualified Data.Map                    as Map+import           Data.Maybe                  (catMaybes, isNothing, mapMaybe) import           Data.Monoid import           Data.Set                    (Set) import qualified Data.Set                    as Set@@ -37,11 +41,13 @@ import qualified Data.Text.Lazy              as LT import           Data.Text.Lazy.Encoding     (decodeUtf8With) import qualified Data.Yaml                   as Yaml+import qualified Distribution.Package        as C import qualified Distribution.PackageDescription as C+import qualified Distribution.Text           as C import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path import           Path.Find                   (findFiles)-import           Path.IO                     (getWorkingDir, parseRelAsAbsDir)+import           Path.IO                     hiding (findExecutable, findFiles) import           Prelude import           Stack.BuildPlan import           Stack.Constants             (stackDotYaml)@@ -53,12 +59,8 @@ import           Stack.Types.Internal        ( HasTerminal                                              , HasReExec                                              , HasLogLevel)-import           System.Directory            (copyFile,-                                              createDirectoryIfMissing,-                                              getTemporaryDirectory,-                                              makeRelativeToCurrentDirectory)+import qualified System.Directory            as D import qualified System.FilePath             as FP-import           System.IO.Temp              (withSystemTempDirectory) import           System.Process.Read  data ConstraintType = Constraint | Preference deriving (Eq)@@ -71,12 +73,13 @@             -> ConstraintSpec -- ^ src constraints             -> ConstraintSpec -- ^ dep constraints             -> [String] -- ^ additional arguments-            -> m (Maybe ConstraintSpec)+            -> m (Either [PackageName] ConstraintSpec) cabalSolver menv cabalfps constraintType             srcConstraints depConstraints cabalArgs =-  withSystemTempDirectory "cabal-solver" $ \dir -> do+  withSystemTempDir "cabal-solver" $ \dir' -> do      let versionConstraints = fmap fst depConstraints+        dir = toFilePath dir'     configLines <- getCabalConfig dir constraintType versionConstraints     let configFile = dir FP.</> "cabal.config"     liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines@@ -87,7 +90,7 @@     --     -- In theory we could use --ignore-sandbox, but not all versions of cabal     -- support it.-    tmpdir <- liftIO getTemporaryDirectory >>= parseRelAsAbsDir+    tmpdir <- getTempDir      let args = ("--config-file=" ++ configFile)              : "install"@@ -103,22 +106,52 @@                toConstraintArgs (flagConstraints constraintType) ++                fmap toFilePath cabalfps -    catch (liftM Just (readProcessStdout (Just tmpdir) menv "cabal" args))+    catch (liftM Right (readProcessStdout (Just tmpdir) menv "cabal" args))           (\ex -> case ex of-              ReadProcessException _ _ _ err -> do-                  let errMsg = decodeUtf8With lenientDecode err-                  if LT.isInfixOf "Could not resolve dependencies" errMsg-                  then do-                      $logInfo "Attempt failed."-                      $logInfo "\n>>>> Cabal errors begin"-                      $logInfo $ LT.toStrict errMsg-                                 <> "<<<< Cabal errors end\n"-                      return Nothing-                  else throwM ex+              ReadProcessException _ _ _ err -> return $ Left err               _ -> throwM ex)-    >>= maybe (return Nothing) parseCabalOutput+    >>= either parseCabalErrors parseCabalOutput    where+    errCheck = T.isInfixOf "Could not resolve dependencies"++    parseCabalErrors err = do+        let errExit e = error $ "Could not parse cabal-install errors:\n"+                              ++ (T.unpack e)+            msg = LT.toStrict $ decodeUtf8With lenientDecode err++        if errCheck msg then do+            $logInfo "Attempt failed."+            $logInfo "\n>>>> Cabal errors begin"+            $logInfo $ msg <> "<<<< Cabal errors end\n"+            let pkgs = parseConflictingPkgs msg+                mPkgNames = map (C.simpleParse . T.unpack) pkgs+                pkgNames  = map (fromCabalPackageName . C.pkgName)+                                (catMaybes mPkgNames)++            when (any isNothing mPkgNames) $ do+                  $logInfo $ "*** Only some package names could be parsed: " <>+                      (T.pack (intercalate ", " (map show pkgNames)))+                  error $ T.unpack $+                       "*** User packages involved in cabal failure: "+                       <> (T.intercalate ", " $ parseConflictingPkgs msg)++            if pkgNames /= [] then do+                  return $ Left pkgNames+            else errExit msg+        else errExit msg++    parseConflictingPkgs msg =+        let ls = dropWhile (not . errCheck) $ T.lines msg+            select s = ((T.isPrefixOf "trying:" s)+                      || (T.isPrefixOf "next goal:" s))+                      && (T.isSuffixOf "(user goal)" s)+            pkgName =   (take 1)+                      . T.words+                      . (T.drop 1)+                      . (T.dropWhile (/= ':'))+        in concat $ map pkgName (filter select ls)+     parseCabalOutput bs = do         let ls = drop 1                $ dropWhile (not . T.isPrefixOf "In order, ")@@ -126,7 +159,7 @@                $ decodeUtf8 bs             (errs, pairs) = partitionEithers $ map parseLine ls         if null errs-          then return $ Just (Map.fromList pairs)+          then return $ Right (Map.fromList pairs)           else error $ "Could not parse cabal-install output: " ++ show errs      parseLine t0 = maybe (Left t0) Right $ do@@ -191,8 +224,8 @@         let dstdir = dir FP.</> T.unpack (indexNameText $ indexName index)             dst = dstdir FP.</> "00-index.tar"         liftIO $ void $ tryIO $ do-            createDirectoryIfMissing True dstdir-            copyFile (toFilePath src) dst+            D.createDirectoryIfMissing True dstdir+            D.copyFile (toFilePath src) dst         return $ T.concat             [ "remote-repo: "             , indexNameText $ indexName index@@ -274,6 +307,9 @@                          \This is most likely a bug."     return menv +-- | Merge two separate maps, one defining constraints on package versions and+-- the other defining package flagmap, into a single map of version and flagmap+-- tuples. mergeConstraints     :: Map PackageName v     -> Map PackageName (Map p f)@@ -295,6 +331,17 @@     | (v == v') && (f == f') = Nothing     | otherwise              = Just (v, f) +-- | Given a resolver, user package constraints (versions and flags) and extra+-- dependency constraints determine what extra dependencies are required+-- outside the resolver snapshot and the specified extra dependencies.+--+-- First it tries by using the snapshot and the input extra dependencies+-- as hard constraints, if no solution is arrived at by using hard+-- constraints it then tries using them as soft constraints or preferences.+--+-- It returns either conflicting packages when no solution is arrived at+-- or the solution in terms of src package flag settings and extra+-- dependencies. solveResolverSpec     :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m        , MonadReader env m, HasConfig env , HasGHCVariant env@@ -307,14 +354,14 @@        , ConstraintSpec) -- ^ ( resolver                          --   , src package constraints                          --   , extra dependency constraints )-    -> m (Maybe ( ConstraintSpec-                , ConstraintSpec)) -- ^ ( resulting src package specs-                                   --   ,  resulting external package specs )+    -> m (Either [PackageName] (ConstraintSpec , ConstraintSpec))+       -- ^ (Conflicting packages+       --    (resulting src package specs, external dependency specs))  solveResolverSpec stackYaml cabalDirs                   (resolver, srcConstraints, extraConstraints) = do     $logInfo $ "Using resolver: " <> resolverName resolver-    (compilerVer, snapConstraints) <- getResolverConstraints resolver+    (compilerVer, snapConstraints) <- getResolverConstraints stackYaml resolver     menv <- setupCabalEnv compilerVer      let -- Note - The order in Map.union below is important.@@ -340,15 +387,15 @@     unless (Map.null depOnlyConstraints)         ($logInfo $ "Trying with " <> srcNames <> " as hard constraints...") -    mdeps <- solver Constraint-    mdeps' <- case mdeps of-        Nothing | not (Map.null depOnlyConstraints) -> do+    eresult <- solver Constraint+    eresult' <- case eresult of+        Left _ | not (Map.null depOnlyConstraints) -> do             $logInfo $ "Retrying with " <> srcNames <> " as preferences..."             solver Preference-        _ -> return mdeps+        _ -> return eresult -    case mdeps' of-        Just deps -> do+    case eresult' of+        Right deps -> do             let                 -- All src package constraints returned by cabal.                 -- Flags may have changed.@@ -367,33 +414,45 @@                      <> T.pack (show $ Map.size external)                      <> " external dependencies." -            return $ Just (srcs, external)-        Nothing -> do-            $logInfo $ "Failed to arrive at a workable build plan using "-                       <> resolverName resolver <> " resolver."-            return Nothing+            return $ Right (srcs, external)+        Left x -> do+            $logInfo $ "*** Failed to arrive at a workable build plan."+            return $ Left x++-- | Given a resolver (snpashot, compiler or custom resolver)+-- return the compiler version, package versions and packages flags+-- for that resolver.+getResolverConstraints+    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m+       , MonadReader env m, HasConfig env , HasGHCVariant env+       , HasHttpManager env , HasLogLevel env , HasReExec env+       , HasTerminal env)+    => Path Abs File+    -> Resolver+    -> m (CompilerVersion,+          Map PackageName (Version, Map FlagName Bool))+getResolverConstraints stackYaml resolver+    | ResolverSnapshot snapName <- resolver = do+        mbp <- loadMiniBuildPlan snapName+        return (mbpCompilerVersion mbp, mbpConstraints mbp)+    | ResolverCustom _ url <- resolver = do+        -- FIXME instead of passing the stackYaml dir we should maintain+        -- the file URL in the custom resolver always relative to stackYaml.+        mbp <- parseCustomMiniBuildPlan stackYaml url+        return (mbpCompilerVersion mbp, mbpConstraints mbp)+    | ResolverCompiler compiler <- resolver =+        return (compiler, Map.empty)+    | otherwise = error "Not reached"     where       mpiConstraints mpi = (mpiVersion mpi, mpiFlags mpi)       mbpConstraints mbp = fmap mpiConstraints (mbpPackages mbp) -      getResolverConstraints (ResolverSnapshot snapName) = do-          mbp <- loadMiniBuildPlan snapName-          return (mbpCompilerVersion mbp, mbpConstraints mbp)--      getResolverConstraints (ResolverCompiler compiler) =-          return (compiler, Map.empty)--      -- FIXME instead of passing the stackYaml dir we should maintain-      -- the file URL in the custom resolver always relative to stackYaml.-      getResolverConstraints (ResolverCustom _ url) = do-          mbp <- parseCustomMiniBuildPlan stackYaml url-          return (mbpCompilerVersion mbp, mbpConstraints mbp)---- | Given a bundle of packages and a resolver, check the resolver with respect--- to the packages and return how well the resolver satisfies the depndencies--- of the packages. If 'flags' is passed as 'Nothing' then flags are chosen+-- | Given a bundle of user packages, flag constraints on those packages and a+-- resolver, determine if the resolver fully, partially or fails to satisfy the+-- dependencies of the user packages.+--+-- If the package flags are passed as 'Nothing' then flags are chosen -- automatically.- checkResolverSpec     :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m        , HasHttpManager env, HasConfig env, HasGHCVariant env@@ -405,10 +464,12 @@ checkResolverSpec gpds flags resolver = do     case resolver of       ResolverSnapshot name -> checkSnapBuildPlan gpds flags name-      ResolverCompiler _ -> return $ BuildPlanCheckPartial Map.empty Map.empty+      ResolverCompiler {} -> return $ BuildPlanCheckPartial Map.empty Map.empty       -- TODO support custom resolver for stack init-      ResolverCustom _ _ -> return $ BuildPlanCheckPartial Map.empty Map.empty+      ResolverCustom {} -> return $ BuildPlanCheckPartial Map.empty Map.empty +-- | Finds all files with a .cabal extension under a given directory.+-- Subdirectories can be included depending on the @recurse@ parameter. findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File] findCabalFiles recurse dir =     liftIO $ findFiles dir isCabal (\subdir -> recurse && not (isIgnored subdir))@@ -426,9 +487,13 @@     , ".stack-work"     ] --- | Do some basic checks on a list of cabal file paths to be used for creating--- stack config, print some informative and error messages and if all is ok--- return @GenericPackageDescription@ list.+-- | Perform some basic checks on a list of cabal files to be used for creating+-- stack config. It checks for duplicate package names, package name and+-- cabal file name mismatch and reports any issues related to those.+--+-- If no error occurs it returns filepath and @GenericPackageDescription@s+-- pairs as well as any filenames for duplicate packages not included in the+-- pairs. cabalPackagesCheck     :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m        , MonadReader env m, HasConfig env , HasGHCVariant env@@ -436,59 +501,82 @@        , HasTerminal env)      => [Path Abs File]      -> String-     -> String-     -> m [C.GenericPackageDescription]-cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter = do+     -> Maybe String+     -> m ( Map PackageName (Path Abs File, C.GenericPackageDescription)+          , [Path Abs File])+cabalPackagesCheck cabalfps noPkgMsg dupErrMsg = do     when (null cabalfps) $         error noPkgMsg -    relpaths <- mapM makeRel cabalfps+    relpaths <- mapM makeRelativeToCurrentDir cabalfps     $logInfo $ "Using cabal packages:"     $logInfo $ T.pack (formatGroup relpaths) -    when (dupGroups relpaths /= []) $-        error $ "Duplicate cabal package names cannot be used in a single "-        <> "stack project. Following duplicates were found:\n"-        <> intercalate "\n" (dupGroups relpaths)-        <> "\n"-        <> dupPkgFooter--    (warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps)+    (warnings, gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps)     zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings-    return gpds -    where-        groups          = filter ((> 1) . length) . groupSortOn (FP.takeFileName)-        dupGroups       = (map formatGroup) . groups+    let packages  = zip cabalfps gpds+        getEmptyNamePkg (fp, gpd)+            | ((show . gpdPackageName) gpd) == "" = Just fp+            | otherwise = Nothing+        emptyNamePkgs = mapMaybe getEmptyNamePkg packages -makeRel :: (MonadIO m) => Path Abs File -> m FilePath-makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath+    when (emptyNamePkgs /= []) $ do+        rels <- mapM makeRelativeToCurrentDir emptyNamePkgs+        error $ "Please assign a name to the following package(s):\n"+                <> (formatGroup rels) -formatGroup :: [String] -> String-formatGroup = concat . (map formatPath)-    where formatPath path = "- " <> path <> "\n"+    let dupGroups = filter ((> 1) . length)+                            . groupSortOn (gpdPackageName . snd)+        dupAll    = concat $ dupGroups packages -reportMissingCabalFiles-    :: (MonadIO m, MonadLogger m) => [Path Abs File] -> Bool -> m ()+        -- Among duplicates prefer to include the ones in upper level dirs+        pathlen     = length . FP.splitPath . toFilePath . fst+        getmin      = minimumBy (compare `on` pathlen)+        dupSelected = map getmin (dupGroups packages)+        dupIgnored  = dupAll \\ dupSelected+        unique      = packages \\ dupIgnored++    when (dupIgnored /= []) $ do+        dups <- mapM (mapM (makeRelativeToCurrentDir . fst)) (dupGroups packages)+        $logWarn $ T.pack $+            "Following packages have duplicate package names:\n"+            <> intercalate "\n" (map formatGroup dups)+        case dupErrMsg of+          Nothing -> $logWarn $ T.pack $+                 "Packages with duplicate names will be ignored.\n"+              <> "Packages in upper level directories will be preferred.\n"+          Just msg -> error msg++    return (Map.fromList+            $ map (\(file, gpd) -> (gpdPackageName gpd,(file, gpd))) unique+           , map fst dupIgnored)++formatGroup :: [Path Rel File] -> String+formatGroup = concatMap formatPath+    where formatPath path = "- " <> toFilePath path <> "\n"++reportMissingCabalFiles :: (MonadIO m, MonadThrow m, MonadLogger m)+  => [Path Abs File]   -- ^ Directories to scan+  -> Bool              -- ^ Whether to scan sub-directories+  -> m () reportMissingCabalFiles cabalfps includeSubdirs = do-    allCabalfps <- findCabalFiles (includeSubdirs) =<< getWorkingDir+    allCabalfps <- findCabalFiles includeSubdirs =<< getCurrentDir -    relpaths <- mapM makeRel (allCabalfps \\ cabalfps)-    when (not (null relpaths)) $ do+    relpaths <- mapM makeRelativeToCurrentDir (allCabalfps \\ cabalfps)+    unless (null relpaths) $ do         $logWarn $ "The following packages are missing from the config:"         $logWarn $ T.pack (formatGroup relpaths) --- | Solver can be thought of as a counterpart of init. init creates a--- stack.yaml whereas solver verifies or fixes an existing one. It can verify--- the dependencies of the packages and determine if any extra-dependecies--- outside the snapshots are needed.--- -- TODO Currently solver uses a stack.yaml in the parent chain when there is -- no stack.yaml in the current directory. It should instead look for a -- stack yaml only in the current directory and suggest init if there is -- none available. That will make the behavior consistent with init and provide -- a correct meaning to a --ignore-subdirs option if implemented. +-- | Verify the combination of resolver, package flags and extra+-- dependencies in an existing stack.yaml and suggest changes in flags or+-- extra dependencies so that the specified packages can be compiled. solveExtraDeps     :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m        , MonadReader env m, HasConfig env , HasEnvConfig env, HasGHCVariant env@@ -501,7 +589,7 @@     bconfig <- asks getBuildConfig      let stackYaml = bcStackYaml bconfig-    relStackYaml <- makeRel stackYaml+    relStackYaml <- toFilePath <$> makeRelativeToCurrentDir stackYaml      $logInfo $ "Using configuration file: " <> T.pack relStackYaml     let cabalDirs = Map.keys $ envConfigPackages econfig@@ -513,13 +601,13 @@                        \entries from '" <> relStackYaml <> "'."      cabalfps  <- liftM concat (mapM (findCabalFiles False) cabalDirs)-    gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter-     -- TODO when solver supports --ignore-subdirs option pass that as the     -- second argument here.     reportMissingCabalFiles cabalfps True+    (bundle, _) <- cabalPackagesCheck cabalfps noPkgMsg (Just dupPkgFooter) -    let oldFlags          = bcFlags bconfig+    let gpds              = Map.elems $ fmap snd bundle+        oldFlags          = bcFlags bconfig         oldExtraVersions  = bcExtraDeps bconfig         resolver          = bcResolver bconfig         oldSrcs           = gpdPackages gpds@@ -533,11 +621,14 @@     resultSpecs <- case resolverResult of         BuildPlanCheckOk flags ->             return $ Just ((mergeConstraints oldSrcs flags), Map.empty)-        BuildPlanCheckPartial _ _ ->-            solveResolverSpec stackYaml cabalDirs+        BuildPlanCheckPartial {} -> do+            eres <- solveResolverSpec stackYaml cabalDirs                               (resolver, srcConstraints, extraConstraints)-        BuildPlanCheckFail f e c ->-            throwM $ ResolverMismatch resolver (showCompilerErrors f e c)+            -- TODO Solver should also use the init code to ignore incompatible+            -- packages+            return $ either (const Nothing) Just eres+        BuildPlanCheckFail {} ->+            throwM $ ResolverMismatch resolver (show resolverResult)      (srcs, edeps) <- case resultSpecs of         Nothing -> throwM (SolverGiveUp giveUpMsg)@@ -568,7 +659,6 @@         -- TODO print whether resolver changed from previous         $logInfo $ "* Resolver is " <> resolverName resolver -        -- TODO indent the yaml output         printFlags newFlags  "* Flags to be added"         printDeps  newVersions   "* Dependencies to be added"
src/Stack/Types/Build.hs view
@@ -339,7 +339,7 @@  data ConstructPlanException     = DependencyCycleDetected [PackageName]-    | DependencyPlanFailures PackageIdentifier (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency))+    | 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)@@ -360,9 +360,10 @@          (DependencyCycleDetected pNames) ->            "While checking call stack,\n" ++            "  dependency cycle detected in packages:" ++ indent (appendLines pNames)-         (DependencyPlanFailures pIdent (Map.toList -> pDeps)) ->+         (DependencyPlanFailures pkg (Map.toList -> pDeps)) ->            "Failure when adding dependencies:" ++ doubleIndent (appendDeps pDeps) ++ "\n" ++-           "  needed for package: " ++ packageIdentifierString pIdent+           "  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"@@ -371,6 +372,12 @@       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@@ -383,7 +390,7 @@                     Nothing -> ""                     Just la -> " (latest applicable is " ++ versionString la ++ ")"            in case badDep of-                NotInBuildPlan -> "not present in build plan" ++ latestApplicableStr+                NotInBuildPlan -> "stack configuration has no specified version" ++ latestApplicableStr                 Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies"                 DependencyMismatch version ->                     case mlatestApplicable of
src/Stack/Types/Config.hs view
@@ -159,6 +159,7 @@ import           Network.HTTP.Client (parseUrl) import           Path import qualified Paths_stack as Meta+import           {-# SOURCE #-} Stack.Constants (stackRootEnvVar) import           Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName) import           Stack.Types.Compiler import           Stack.Types.Docker@@ -278,6 +279,9 @@          ,configDefaultTemplate     :: !(Maybe TemplateName)          -- ^ The default template to use when none is specified.          -- (If Nothing, the default default is used.)+         ,configAllowDifferentUser  :: !Bool+         -- ^ Allow users other than the stack root owner to use the stack+         -- installation.          }  -- | Which packages to ghc-options on the command line apply to?@@ -572,14 +576,14 @@     deriving Show  data RemotePackageType-    = RPTHttpTarball+    = RPTHttp     | RPTGit Text -- ^ Commit     | RPTHg  Text -- ^ Commit     deriving Show  instance ToJSON PackageLocation where     toJSON (PLFilePath fp) = toJSON fp-    toJSON (PLRemote t RPTHttpTarball) = toJSON t+    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] @@ -592,8 +596,9 @@         file t = pure $ PLFilePath $ T.unpack t         http t =             case parseUrl $ T.unpack t of-                Left _ -> mzero-                Right _ -> return $ PLRemote t RPTHttpTarball+                Left  _ -> mzero+                Right _ -> return $ PLRemote t RPTHttp+         git = withObjectWarnings "PackageGitLocation" $ \o -> PLRemote             <$> o ..: "git"             <*> (RPTGit <$> o ..: "commit")@@ -604,7 +609,10 @@ -- | A project is a collection of packages. We can have multiple stack.yaml -- files, but only one of them may contain project information. data Project = Project-    { projectPackages :: ![PackageEntry]+    { projectUserMsg :: !(Maybe String)+    -- ^ A warning message to display to the user when the auto generated+    -- config may have issues.+    , projectPackages :: ![PackageEntry]     -- ^ Components of the package list     , projectExtraDeps :: !(Map PackageName Version)     -- ^ Components of the package list referring to package/version combos,@@ -622,12 +630,13 @@ instance ToJSON Project where     toJSON p = object $         (maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p))+        ((maybe id (\msg -> (("user-message" .= msg) :)) (projectUserMsg p))         [ "packages"          .= projectPackages p         , "extra-deps"        .= map fromTuple (Map.toList $ projectExtraDeps p)         , "flags"             .= projectFlags p         , "resolver"          .= projectResolver p         , "extra-package-dbs" .= projectExtraPackageDBs p-        ]+        ])  -- | How we resolve which dependencies to install given a set of packages. data Resolver@@ -801,6 +810,9 @@     ,configMonoidDefaultTemplate     :: !(Maybe TemplateName)     -- ^ The default template to use when none is specified.     -- (If Nothing, the default default is used.)+    , configMonoidAllowDifferentUser :: !(Maybe Bool)+    -- ^ Allow users other than the stack root owner to use the stack+    -- installation.     }   deriving Show @@ -840,6 +852,7 @@     , configMonoidApplyGhcOptions = Nothing     , configMonoidAllowNewer = Nothing     , configMonoidDefaultTemplate = Nothing+    , configMonoidAllowDifferentUser = Nothing     }   mappend l r = ConfigMonoid     { configMonoidWorkDir = configMonoidWorkDir l <|> configMonoidWorkDir r@@ -877,6 +890,7 @@     , configMonoidApplyGhcOptions = configMonoidApplyGhcOptions l <|> configMonoidApplyGhcOptions r     , configMonoidAllowNewer = configMonoidAllowNewer l <|> configMonoidAllowNewer r     , configMonoidDefaultTemplate = configMonoidDefaultTemplate l <|> configMonoidDefaultTemplate r+    , configMonoidAllowDifferentUser = configMonoidAllowDifferentUser l <|> configMonoidAllowDifferentUser r     }  instance FromJSON (ConfigMonoid, [JSONWarning]) where@@ -941,6 +955,7 @@     configMonoidApplyGhcOptions <- obj ..:? configMonoidApplyGhcOptionsName     configMonoidAllowNewer <- obj ..:? configMonoidAllowNewerName     configMonoidDefaultTemplate <- obj ..:? configMonoidDefaultTemplateName+    configMonoidAllowDifferentUser <- obj ..:? configMonoidAllowDifferentUserName      return ConfigMonoid {..}   where@@ -1069,17 +1084,24 @@ configMonoidDefaultTemplateName :: Text configMonoidDefaultTemplateName = "default-template" +configMonoidAllowDifferentUserName :: Text+configMonoidAllowDifferentUserName = "allow-different-user"+ data ConfigException   = ParseConfigFileException (Path Abs File) ParseException   | ParseResolverException Text   | NoProjectConfigFound (Path Abs Dir) (Maybe Text)-  | UnexpectedTarballContents [Path Abs Dir] [Path Abs File]+  | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File]+  | UnableToExtractArchive Text (Path Abs File)   | BadStackVersionException VersionRange   | NoMatchingSnapshot [SnapName]-  | ResolverMismatch Resolver Text-  | ResolverPartial Resolver Text+  | ResolverMismatch Resolver String+  | ResolverPartial Resolver String   | NoSuchDirectory FilePath   | ParseGHCVariantException String+  | BadStackRootEnvVar (Path Abs Dir)+  | Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir) -- ^ @$STACK_ROOT@, parent dir+  | UserDoesn'tOwnDirectory (Path Abs Dir)   deriving Typeable instance Show ConfigException where     show (ParseConfigFileException configFile exception) = concat@@ -1087,7 +1109,7 @@         , toFilePath configFile         , "':\n"         , show exception-        , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration.html."+        , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/."         ]     show (ParseResolverException t) = concat         [ "Invalid resolver value: "@@ -1103,13 +1125,17 @@             Nothing -> ""             Just cmd -> "\nRecommended action: stack " ++ T.unpack cmd         ]-    show (UnexpectedTarballContents dirs files) = concat-        [ "When unpacking a tarball specified in your stack.yaml file, "+    show (UnexpectedArchiveContents dirs files) = concat+        [ "When unpacking an archive specified in your stack.yaml file, "         , "did not find expected contents. Expected: a single directory. Found: "         , show ( map (toFilePath . dirname) dirs                , map (toFilePath . filename) files                )         ]+    show (UnableToExtractArchive url file) = concat+        [ "Archive extraction failed. We support tarballs and zip, couldn't handle the following URL, "+        , T.unpack url, " downloaded to the file ", toFilePath $ filename file+        ]     show (BadStackVersionException requiredRange) = concat         [ "The version of stack you are using ("         , show (fromCabalVersion Meta.version)@@ -1123,23 +1149,23 @@         , unlines $ map (\name -> "    - " <> T.unpack (renderSnapName name))                         names         , "\nYou can try the following options:\n"-        , "    - Exclude mismatching package(s) and build the rest.\n"-        , "        - Use '--ignore-subdirs' to exclude subdirectories.\n"-        , "        - Manually create a config, then use 'stack solver'\n"+        , "    - Use '--omit-packages to exclude mismatching package(s).\n"         , "    - Use '--resolver' to specify a matching snapshot/resolver\n"-        , "    - Use a custom snapshot having the right compiler.\n"         ]     show (ResolverMismatch resolver errDesc) = concat-        [ "Selected resolver '"+        [ "Resolver '"         , T.unpack (resolverName resolver)-        , "' does not have a matching compiler to build your package(s).\n"-        , T.unpack errDesc+        , "' does not have a matching compiler to build some or all of your "+        , "package(s).\n"+        , errDesc+        , "\nHowever, you can try '--omit-packages to exclude mismatching "+        , "package(s)."         ]     show (ResolverPartial resolver errDesc) = concat-        [ "Selected resolver '"+        [ "Resolver '"         , T.unpack (resolverName resolver)         , "' does not have all the packages to match your requirements.\n"-        , T.unpack $ T.unlines $ fmap ("    " <>) (T.lines errDesc)+        , unlines $ fmap ("    " <>) (lines errDesc)         , "\nHowever, you can try '--solver' to use external packages."         ]     show (NoSuchDirectory dir) = concat@@ -1150,6 +1176,30 @@         [ "Invalid ghc-variant value: "         , v         ]+    show (BadStackRootEnvVar envStackRoot) = concat+        [ "Invalid $"+        , stackRootEnvVar+        , ": '"+        , toFilePath envStackRoot+        , "'. Please provide a valid absolute path."+        ]+    show (Won'tCreateStackRootInDirectoryOwnedByDifferentUser envStackRoot parentDir) = concat+        [ "Preventing creation of $"+        , stackRootEnvVar+        , " '"+        , toFilePath envStackRoot+        , "'. Parent directory '"+        , toFilePath parentDir+        , "' is owned by someone else."+        ]+    show (UserDoesn'tOwnDirectory dir) = concat+        [ "You are not the owner of '"+        , toFilePath dir+        , "'. Aborting to protect file permissions."+        , "\nRetry with '--"+        , T.unpack configMonoidAllowDifferentUserName+        , "' to disable this precaution."+        ] instance Exception ConfigException  -- | Helper function to ask the environment and apply getConfig@@ -1373,10 +1423,12 @@         flags <- o ..:? "flags" ..!= mempty         resolver <- jsonSubWarnings (o ..: "resolver")         compiler <- o ..:? "compiler"+        msg <- o ..:? "user-message"         config <- parseConfigMonoidJSON o         extraPackageDBs <- o ..:? "extra-package-dbs" ..!= []         let project = Project-                { projectPackages = dirs+                { projectUserMsg = msg+                , projectPackages = dirs                 , projectExtraDeps = extraDeps                 , projectFlags = flags                 , projectResolver = resolver
src/Stack/Types/Package.hs view
@@ -98,6 +98,10 @@           }  deriving (Show,Typeable) +packageIdentifier :: Package -> PackageIdentifier+packageIdentifier pkg =+    PackageIdentifier (packageName pkg) (packageVersion pkg)+ -- | Files that the package depends on, relative to package directory. -- Argument is the location of the .cabal file newtype GetPackageOpts = GetPackageOpts
src/Stack/Types/StackT.hs view
@@ -256,11 +256,11 @@                 case level of                     LevelOther "sticky-done" -> do                         clear-                        liftIO (T.hPutStrLn out msgText)+                        liftIO (T.hPutStrLn out msgText >> hFlush out)                         return Nothing                     LevelOther "sticky" -> do                         clear-                        liftIO (T.hPutStr out msgText)+                        liftIO (T.hPutStr out msgText >> hFlush out)                         return (Just msgText)                     _                       | level >= maxLogLevel -> do@@ -270,7 +270,7 @@                               Nothing ->                                   return Nothing                               Just line -> do-                                  liftIO (T.hPutStr out line)+                                  liftIO (T.hPutStr out line >> hFlush out)                                   return sticky                       | otherwise ->                           return sticky
src/Stack/Upgrade.hs view
@@ -39,7 +39,7 @@         -> Maybe String -- ^ git hash at time of building, if known         -> m () upgrade gitRepo mresolver builtHash =-  withCanonicalizedSystemTempDirectory "stack-upgrade" $ \tmp -> do+  withSystemTempDir "stack-upgrade" $ \tmp -> do     menv <- getMinimalEnvOverride     mdir <- case gitRepo of       Just repo -> do
src/System/Process/Read.hs view
@@ -62,10 +62,10 @@ import qualified Data.Text.Lazy as LT import           Data.Typeable (Typeable) import           Distribution.System (OS (Windows), Platform (Platform))-import           Path (Path, Abs, Dir, toFilePath, File, parseAbsFile)-import           Path.IO (createTree, parseRelAsAbsFile)+import           Path+import           Path.IO hiding (findExecutable) import           Prelude -- Fix AMP warning-import           System.Directory (doesFileExist, getCurrentDirectory)+import qualified System.Directory as D import           System.Environment (getEnvironment) import           System.Exit import qualified System.FilePath as FP@@ -298,34 +298,29 @@ -- | Perform pre-call-process tasks.  Ensure the working directory exists and find the -- executable path. preProcess :: (MonadIO m)-           => Maybe (Path Abs Dir) -- ^ Optional directory to create if necessary-           -> EnvOverride-           -> String -- ^ Command name-           -> m FilePath+  => Maybe (Path Abs Dir) -- ^ Optional directory to create if necessary+  -> EnvOverride       -- ^ How to override environment+  -> String            -- ^ Command name+  -> m FilePath preProcess wd menv name = do   name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name-  maybe (return ()) createTree wd+  maybe (return ()) ensureDir wd   return name'  -- | Check if the given executable exists on the given PATH.-doesExecutableExist :: MonadIO m => EnvOverride -> String -> m Bool+doesExecutableExist :: (MonadIO m)+  => EnvOverride       -- ^ How to override environment+  -> String            -- ^ Name of executable+  -> m Bool doesExecutableExist menv name = liftM isJust $ findExecutable menv name --- | Turn a relative path into an absolute path.------   Note: this function duplicates the functionality of makeAbsolute---   in recent versions of "System.Directory", and can be removed once---   we no longer need to support older versions of GHC.-makeAbsolute :: FilePath -> IO FilePath-makeAbsolute = fmap FP.normalise . absolutize-  where absolutize path-          | FP.isRelative path = fmap (FP.</> path) getCurrentDirectory-          | otherwise          = return path- -- | Find the complete path for the executable. -- -- Throws a 'ReadProcessException' if unsuccessful.-findExecutable :: (MonadIO m, MonadThrow n) => EnvOverride -> String -> m (n (Path Abs File))+findExecutable :: (MonadIO m, MonadThrow n)+  => EnvOverride       -- ^ How to override environment+  -> 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]@@ -333,10 +328,10 @@             | otherwise = [name0 ++ eoExeExtension eo, name0]         testNames [] = return $ throwM $ ExecutableNotFoundAt name0         testNames (name:names) = do-            exists <- liftIO $ doesFileExist name+            exists <- liftIO $ D.doesFileExist name             if exists                 then do-                    path <- liftIO $ parseRelAsAbsFile name+                    path <- liftIO $ resolveFile' name                     return $ return path                 else testNames names     testNames names0@@ -354,10 +349,10 @@                             | otherwise = [fp0 ++ eoExeExtension eo, fp0]                         testFPs [] = loop dirs                         testFPs (fp:fps) = do-                            exists <- doesFileExist fp+                            exists <- D.doesFileExist fp                             if exists                                 then do-                                    fp' <- makeAbsolute fp >>= parseAbsFile+                                    fp' <- D.makeAbsolute fp >>= parseAbsFile                                     return $ return fp'                                 else testFPs fps                     testFPs fps0
src/main/Main.hs view
@@ -75,7 +75,7 @@ import           Stack.Init import           Stack.New import           Stack.Options-import           Stack.Package (getCabalFileName)+import           Stack.Package (findOrGenerateCabalFile) import qualified Stack.PackageIndex import           Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball') import           Stack.Setup@@ -86,8 +86,7 @@ import           Stack.Types.StackT import           Stack.Upgrade import qualified Stack.Upload as Upload-import           System.Directory (canonicalizePath, doesFileExist, doesDirectoryExist, createDirectoryIfMissing)-import qualified System.Directory as Directory (findExecutable)+import qualified System.Directory as D import           System.Environment (getEnvironment, getProgName, getArgs, withArgs) import           System.Exit import           System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock)@@ -235,11 +234,9 @@                     "List the templates available for `stack new'."                     templatesCmd                     (pure ())-        addCommand  "init"+        addCommand' "init"                     "Initialize a stack project based on one or more cabal packages"-                    globalFooter                     initCmd-                    (globalOpts InitCmdGlobalOpts)                     initOptsParser         addCommand' "solver"                     "Use a dependency solver to try and determine missing extra-deps"@@ -439,7 +436,6 @@         addSubCommands' cmd title =             addSubCommands cmd title globalFooter (globalOpts OtherCmdGlobalOpts) -     globalOpts kind =         extraHelpOption hide progName (Docker.dockerCmdName ++ "*") Docker.dockerHelpOptName <*>         extraHelpOption hide progName (Nix.nixCmdName ++ "*") Nix.nixHelpOptName <*>@@ -458,11 +454,11 @@   -> ParserFailure ParserHelp   -> IO (ParserFailure ParserHelp) secondaryCommandHandler args f =-    -- don't even try when the argument looks like a path-    if elem pathSeparator cmd+    -- don't even try when the argument looks like a path or flag+    if elem pathSeparator cmd || "-" `isPrefixOf` cmd        then return f     else do-      mExternalExec <- Directory.findExecutable cmd+      mExternalExec <- D.findExecutable cmd       case mExternalExec of         Just ex -> do           menv <- getEnvOverride buildPlatform@@ -485,7 +481,7 @@   -> ParserFailure ParserHelp   -> IO (GlobalOptsMonoid, (GlobalOpts -> IO (), t)) interpreterHandler args f = do-  isFile <- doesFileExist file+  isFile <- D.doesFileExist file   if isFile   then runInterpreterCommand file   else parseResultHandler (errorCombine (noSuchFile file))@@ -764,7 +760,7 @@         then do             let lockfile = $(mkRelFile "lockfile")             let pth = dir </> lockfile-            liftIO $ createDirectoryIfMissing True (toFilePath dir)+            ensureDir dir             -- Just in case of asynchronous exceptions, we need to be careful             -- when using tryLockFile here:             EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive)@@ -925,8 +921,8 @@             r <- f x             (as, bs) <- partitionM f xs             return $ if r then (x:as, bs) else (as, x:bs)-    (files, nonFiles) <- partitionM doesFileExist args-    (dirs, invalid) <- partitionM doesDirectoryExist nonFiles+    (files, nonFiles) <- partitionM D.doesFileExist args+    (dirs, invalid) <- partitionM D.doesDirectoryExist nonFiles     unless (null invalid) $ error $         "stack upload expects a list sdist tarballs or cabal directories.  Can't find " ++         show invalid@@ -942,11 +938,11 @@     withBuildConfigAndLock go $ \_ -> do         uploader <- getUploader         unless ignoreCheck $-            mapM_ (parseRelAsAbsFile >=> checkSDistTarball) files+            mapM_ (resolveFile' >=> checkSDistTarball) files         forM_             files             (\file ->-                  do tarFile <- parseRelAsAbsFile file+                  do tarFile <- resolveFile' file                      liftIO                          (Upload.upload uploader (toFilePath tarFile))                      when@@ -957,7 +953,7 @@                               tarFile))         unless (null dirs) $             forM_ dirs $ \dir -> do-                pkgDir <- parseRelAsAbsDir dir+                pkgDir <- resolveDir' dir                 (tarName, tarBytes) <- getSDistTarball mpvpBounds pkgDir                 unless ignoreCheck $ checkSDistTarball' tarName tarBytes                 liftIO $ Upload.uploadBytes uploader tarName tarBytes@@ -976,12 +972,12 @@         -- If no directories are specified, build all sdist tarballs.         dirs' <- if null dirs             then asks (Map.keys . envConfigPackages . getEnvConfig)-            else mapM (parseAbsDir <=< liftIO . canonicalizePath) dirs+            else mapM resolveDir' dirs         forM_ dirs' $ \dir -> do             (tarName, tarBytes) <- getSDistTarball mpvpBounds dir             distDir <- distDirFromDir dir             tarPath <- (distDir </>) <$> parseRelFile tarName-            liftIO $ createTree $ parent tarPath+            ensureDir (parent tarPath)             liftIO $ L.writeFile (toFilePath tarPath) tarBytes             unless ignoreCheck (checkSDistTarball tarPath)             $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath)@@ -1067,7 +1063,7 @@          locals <-              forM (M.toList (envConfigPackages econfig)) $              \(dir,_) ->-                  do cabalfp <- getCabalFileName dir+                  do cabalfp <- findOrGenerateCabalFile dir                      parsePackageNameFromFilePath cabalfp          forM_ locals (liftIO . putStrLn . packageNameString) @@ -1076,8 +1072,8 @@ targetsCmd target go@GlobalOpts{..} =     withBuildConfig go $     do let bopts = defaultBuildOpts { boptsTargets = [target] }-       (_realTargets,_,pkgs) <- ghciSetup bopts False False Nothing []-       pwd <- getWorkingDir+       (_realTargets,_,pkgs) <- ghciSetup (ideGhciOpts bopts)+       pwd <- getCurrentDir        targets <-            fmap                (concat . snd . unzip)@@ -1139,7 +1135,7 @@     withConfigAndLock         go         (do (manager,lc) <- liftIO (loadConfigWithOpts go)-            tarBall <- parseRelAsAbsFile path+            tarBall <- resolveFile' path             runStackTGlobal                 manager                 (lcConfig lc)@@ -1151,12 +1147,7 @@ loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO)) loadConfigWithOpts go@GlobalOpts{..} = do     manager <- newTLSManager-    mstackYaml <--        case globalStackYaml of-            Nothing -> return Nothing-            Just fp -> do-                path <- canonicalizePath fp >>= parseAbsFile-                return $ Just path+    mstackYaml <- forM globalStackYaml resolveFile'     lc <- runStackLoggingTGlobal manager go $ do         lc <- loadConfig globalConfigMonoid mstackYaml globalResolver         -- If we have been relaunched in a Docker container, perform in-container initialization@@ -1182,16 +1173,15 @@ -- | Project initialization initCmd :: InitOpts -> GlobalOpts -> IO () initCmd initOpts go = do-    pwd <- getWorkingDir-    withMiniConfigAndLock go (initProject pwd initOpts)+    pwd <- getCurrentDir+    withMiniConfigAndLock go (initProject pwd initOpts (globalResolver go))  -- | Create a project directory structure and initialize the stack config. newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO () newCmd (newOpts,initOpts) go@GlobalOpts{..} = do     withMiniConfigAndLock go $ do-        dir <- new newOpts-        initProject dir initOpts-+        dir <- new newOpts (forceOverwrite initOpts)+        initProject dir initOpts globalResolver  -- | List the available templates. templatesCmd :: () -> GlobalOpts -> IO ()
src/test/Network/HTTP/Download/VerifiedSpec.hs view
@@ -10,14 +10,11 @@ import Network.HTTP.Download.Verified import Path import Path.IO-import System.Directory import Test.Hspec hiding (shouldNotBe, shouldNotReturn) - -- TODO: share across test files-withTempDir :: (Path Abs Dir -> IO a) -> IO a-withTempDir = withCanonicalizedSystemTempDirectory "NHD_VerifiedSpec"-+withTempDir' :: (Path Abs Dir -> IO a) -> IO a+withTempDir' = withSystemTempDir "NHD_VerifiedSpec"  -- | An example path to download the exampleReq. getExamplePath :: Path Abs Dir -> IO (Path Abs File)@@ -96,59 +93,54 @@     -- Preconditions:     -- * the exampleReq server is running     -- * the test runner has working internet access to it-    it "downloads the file correctly" $ \T{..} -> withTempDir $ \dir -> do+    it "downloads the file correctly" $ \T{..} -> withTempDir' $ \dir -> do       examplePath <- getExamplePath dir-      let exampleFilePath = toFilePath examplePath-      doesFileExist exampleFilePath `shouldReturn` False+      doesFileExist examplePath `shouldReturn` False       let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook       go `shouldReturn` True-      doesFileExist exampleFilePath `shouldReturn` True+      doesFileExist examplePath `shouldReturn` True -    it "is idempotent, and doesn't redownload unnecessarily" $ \T{..} -> withTempDir $ \dir -> do+    it "is idempotent, and doesn't redownload unnecessarily" $ \T{..} -> withTempDir' $ \dir -> do       examplePath <- getExamplePath dir-      let exampleFilePath = toFilePath examplePath-      doesFileExist exampleFilePath `shouldReturn` False+      doesFileExist examplePath `shouldReturn` False       let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook       go `shouldReturn` True-      doesFileExist exampleFilePath `shouldReturn` True+      doesFileExist examplePath `shouldReturn` True       go `shouldReturn` False-      doesFileExist exampleFilePath `shouldReturn` True+      doesFileExist examplePath `shouldReturn` True      -- https://github.com/commercialhaskell/stack/issues/372-    it "does redownload when the destination file is wrong" $ \T{..} -> withTempDir $ \dir -> do+    it "does redownload when the destination file is wrong" $ \T{..} -> withTempDir' $ \dir -> do       examplePath <- getExamplePath dir       let exampleFilePath = toFilePath examplePath       writeFile exampleFilePath exampleWrongContent-      doesFileExist exampleFilePath `shouldReturn` True+      doesFileExist examplePath `shouldReturn` True       readFile exampleFilePath `shouldReturn` exampleWrongContent       let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook       go `shouldReturn` True-      doesFileExist exampleFilePath `shouldReturn` True+      doesFileExist examplePath `shouldReturn` True       readFile exampleFilePath `shouldNotReturn` exampleWrongContent -    it "rejects incorrect content length" $ \T{..} -> withTempDir $ \dir -> do+    it "rejects incorrect content length" $ \T{..} -> withTempDir' $ \dir -> do       examplePath <- getExamplePath dir-      let exampleFilePath = toFilePath examplePath       let wrongContentLengthReq = exampleReq             { drLengthCheck = Just exampleWrongContentLength             }       let go = runWith manager $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook       go `shouldThrow` isWrongContentLength-      doesFileExist exampleFilePath `shouldReturn` False+      doesFileExist examplePath `shouldReturn` False -    it "rejects incorrect digest" $ \T{..} -> withTempDir $ \dir -> do+    it "rejects incorrect digest" $ \T{..} -> withTempDir' $ \dir -> do       examplePath <- getExamplePath dir-      let exampleFilePath = toFilePath examplePath       let wrongHashCheck = exampleHashCheck { hashCheckHexDigest = exampleWrongDigest }       let wrongDigestReq = exampleReq { drHashChecks = [wrongHashCheck] }       let go = runWith manager $ verifiedDownload wrongDigestReq examplePath exampleProgressHook       go `shouldThrow` isWrongDigest-      doesFileExist exampleFilePath `shouldReturn` False+      doesFileExist examplePath `shouldReturn` False      -- https://github.com/commercialhaskell/stack/issues/240-    it "can download hackage tarballs" $ \T{..} -> withTempDir $ \dir -> do+    it "can download hackage tarballs" $ \T{..} -> withTempDir' $ \dir -> do       dest <- fmap (dir </>) $ parseRelFile "acme-missiles-0.3.tar.gz"-      let destFp = toFilePath dest       req <- parseUrl "http://hackage.haskell.org/package/acme-missiles-0.3/acme-missiles-0.3.tar.gz"       let dReq = DownloadRequest             { drRequest = req@@ -157,6 +149,6 @@             , drRetryPolicy = limitRetries 1             }       let go = runWith manager $ verifiedDownload dReq dest exampleProgressHook-      doesFileExist destFp `shouldReturn` False+      doesFileExist dest `shouldReturn` False       go `shouldReturn` True-      doesFileExist destFp `shouldReturn` True+      doesFileExist dest `shouldReturn` True
src/test/Stack/ConfigSpec.hs view
@@ -60,7 +60,6 @@         let resetVar = setEnv name originalValue         bracket_ setVar resetVar action -   describe "loadConfig" $ do     let loadConfig' m = runStackLoggingT m logLevel False False (loadConfig mempty Nothing Nothing)     let loadBuildConfigRest m = runStackLoggingT m logLevel False False@@ -86,7 +85,7 @@       bcRoot bc `shouldBe` parentDir      it "respects the STACK_YAML env variable" $ \T{..} -> inTempDir $ do-      withCanonicalizedSystemTempDirectory "config-is-here" $ \dir -> do+      withSystemTempDir "config-is-here" $ \dir -> do         let stackYamlFp = toFilePath (dir </> stackDotYaml)         writeFile stackYamlFp sampleConfig         withEnvVar "STACK_YAML" stackYamlFp $ do
stack.cabal view
@@ -1,5 +1,5 @@ name: stack-version: 1.0.2+version: 1.0.4 cabal-version: >=1.10 build-type: Simple license: BSD3@@ -56,9 +56,32 @@         build-depends:             unix >=2.7.0.1 && <2.8     exposed-modules:-        Options.Applicative.Builder.Extra+        Control.Concurrent.Execute+        Data.Aeson.Extended+        Data.Attoparsec.Args+        Data.Attoparsec.Combinators+        Data.Attoparsec.Interpreter+        Data.Binary.VersionTagged+        Data.IORef.RunOnce+        Data.Maybe.Extra+        Data.Set.Monad+        Distribution.Version.Extra+        Network.HTTP.Download+        Network.HTTP.Download.Verified         Options.Applicative.Args+        Options.Applicative.Builder.Extra         Options.Applicative.Complicated+        Path.Extra+        Path.Find+        Paths_stack+        Stack.Build+        Stack.Build.Cache+        Stack.Build.ConstructPlan+        Stack.Build.Execute+        Stack.Build.Haddock+        Stack.Build.Installed+        Stack.Build.Source+        Stack.Build.Target         Stack.BuildPlan         Stack.Clean         Stack.Config@@ -70,10 +93,13 @@         Stack.Docker         Stack.Docker.GlobalDB         Stack.Dot-        Stack.Fetch         Stack.Exec+        Stack.Fetch         Stack.FileWatch         Stack.GhcPkg+        Stack.Ghci+        Stack.Ide+        Stack.Image         Stack.Init         Stack.New         Stack.Nix@@ -81,15 +107,15 @@         Stack.Package         Stack.PackageDump         Stack.PackageIndex-        Stack.Ghci-        Stack.Ide-        Stack.Image         Stack.SDist         Stack.Setup         Stack.Setup.Installed+        Stack.Sig+        Stack.Sig.GPG+        Stack.Sig.Sign         Stack.Solver         Stack.Types-        Stack.Types.Internal+        Stack.Types.Build         Stack.Types.BuildPlan         Stack.Types.Compiler         Stack.Types.Config@@ -97,54 +123,36 @@         Stack.Types.FlagName         Stack.Types.GhcPkgId         Stack.Types.Image+        Stack.Types.Internal         Stack.Types.Nix+        Stack.Types.Package         Stack.Types.PackageIdentifier         Stack.Types.PackageIndex         Stack.Types.PackageName-        Stack.Types.TemplateName-        Stack.Types.Version         Stack.Types.Sig         Stack.Types.StackT-        Stack.Types.Build-        Stack.Types.Package-        Stack.Build-        Stack.Build.Cache-        Stack.Build.ConstructPlan-        Stack.Build.Execute-        Stack.Build.Haddock-        Stack.Build.Installed-        Stack.Build.Source-        Stack.Build.Target-        Stack.Sig-        Stack.Sig.GPG-        Stack.Sig.Sign+        Stack.Types.TemplateName+        Stack.Types.Version         Stack.Upgrade         Stack.Upload-        System.Process.Read         System.Process.Log+        System.Process.PagerEditor+        System.Process.Read         System.Process.Run-        Network.HTTP.Download.Verified-        Data.Attoparsec.Args-        Data.Attoparsec.Interpreter-        Data.Maybe.Extra-        Path.IO-        Path.Extra     build-depends:         Cabal >=1.18.1.5 && <1.23,-        aeson >=0.8.0.2 && <0.11,+        aeson >=0.8.0.2 && <0.10 || ==0.11.*,         ansi-terminal >=0.6.2.3 && <0.7,         async >=2.0.2 && <2.2,         attoparsec >=0.12.1.5 && <0.14,         base >=4.7 && <5,         base16-bytestring >=0.1.1.6 && <0.2,         base64-bytestring >=1.0.0.1 && <1.1,-        bifunctors >=4.2.1 && <5.3,         binary ==0.7.*,         binary-tagged >=0.1.1 && <0.2,         blaze-builder >=0.4.0.1 && <0.5,         byteable >=0.1.1 && <0.2,         bytestring >=0.10.6.0 && <0.11,-        conduit-combinators >=0.3.1 && <1.1,         conduit >=1.2.4 && <1.3,         conduit-extra >=1.1.7.1 && <1.2,         containers >=0.5.5.1 && <0.6,@@ -154,9 +162,9 @@         edit-distance ==0.2.*,         either >=4.4.1 && <4.5,         enclosed-exceptions >=1.0.1.1 && <1.1,-        errors >=2.0.1 && <2.2,+        errors >=2.1.1 && <2.2,         exceptions >=0.8.0.2 && <0.9,-        extra >=1.4.2 && <1.5,+        extra >=1.4.3 && <1.5,         fast-logger >=2.3.1 && <2.5,         filelock >=0.1.0.1 && <0.2,         filepath >=1.3.0.2 && <1.5,@@ -170,11 +178,10 @@         lifted-base >=0.2.3.6 && <0.3,         monad-control >=1.0.0.4 && <1.1,         monad-logger >=0.3.13.1 && <0.4,-        monad-loops >=0.4.2.1 && <0.5,         mtl >=2.1.3.1 && <2.3,-        old-locale >=1.0.0.6 && <1.1,         optparse-applicative >=0.11 && <0.13,         path >=0.5.1 && <0.6,+        path-io >=0.3.1 && <1.0.0,         persistent >=2.1.2 && <2.3,         persistent-sqlite >=2.1.4 && <2.3,         persistent-template >=2.1.1 && <2.2,@@ -184,7 +191,7 @@         retry >=0.6 && <0.8,         safe ==0.3.*,         semigroups >=0.5 && <0.19,-        split >=0.2.2 && <0.3,+        split >=0.2.3 && <0.3,         stm >=2.4.4 && <2.5,         streaming-commons >=0.1.10.0 && <0.2,         tar >=0.4.1.0 && <0.6,@@ -199,29 +206,16 @@         unordered-containers >=0.2.5.1 && <0.3,         vector >=0.10.12.3 && <0.12,         vector-binary-instances >=0.2.1.0 && <0.3,-        void ==0.7.*,         yaml >=0.8.10.1 && <0.9,         zlib >=0.5.4.2 && <0.7,         deepseq ==1.4.*,-        file-embed >=0.0.9 && <0.1,-        word8 >=0.1.2 && <0.2,         hastache >=0.6.1 && <0.7,         project-template ==0.2.*,-        uuid >=1.3.11 && <1.4+        uuid >=1.3.11 && <1.4,+        zip-archive >=0.2.3.7 && <0.3,+        hpack >=0.9.0 && <0.10     default-language: Haskell2010     hs-source-dirs: src/-    other-modules:-        Network.HTTP.Download-        Control.Concurrent.Execute-        Path.Find-        System.Process.PagerEditor-        Paths_stack-        Data.Aeson.Extended-        Data.Attoparsec.Combinators-        Data.Binary.VersionTagged-        Data.IORef.RunOnce-        Data.Set.Monad-        Distribution.Version.Extra     ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates  executable stack@@ -241,33 +235,24 @@         cpp-options: -DUSE_GIT_INFO     main-is: Main.hs     build-depends:+        Cabal >=1.18.1.5 && <1.23,         base >=4.7 && <5,         bytestring >=0.10.4.0 && <0.11,-        Cabal >=1.22.6.0 && <1.23,         containers >=0.5.5.1 && <0.6,-        exceptions >=0.8.0.2 && <0.9,-        filepath >=1.4.0.0 && <1.5,+        directory >=1.2.2.0 && <1.3,         filelock >=0.1.0.1 && <0.2,-        http-conduit >=2.1.5 && <2.2,+        filepath >=1.4.0.0 && <1.5,+        http-client >=0.4.27 && <0.5,         lifted-base >=0.2.3.6 && <0.3,         monad-control >=1.0.0.4 && <1.1,         monad-logger >=0.3.13.1 && <0.4,         mtl >=2.1.3.1 && <2.3,-        old-locale >=1.0.0.6 && <1.1,         optparse-applicative >=0.11.0.2 && <0.13,         path >=0.5.3 && <0.6,-        process >=1.2.3.0 && <1.3,-        resourcet >=1.1.4.1 && <1.2,-        stack >=1.0.2 && <1.1,+        path-io >=0.3.1 && <0.4,+        stack >=1.0.4 && <1.1,         text >=1.2.0.4 && <1.3,-        either >=4.4.1 && <4.5,-        directory >=1.2.2.0 && <1.3,-        split >=0.2.2 && <0.3,-        unordered-containers >=0.2.5.1 && <0.3,-        hashable >=1.2.3.3 && <1.3,-        conduit >=1.2.6.1 && <1.3,-        transformers >=0.4.2.0 && <0.5,-        http-client >=0.4.26.2 && <0.5+        transformers >=0.4.2.0 && <0.5     default-language: Haskell2010     hs-source-dirs: src/main     other-modules:@@ -278,29 +263,27 @@     type: exitcode-stdio-1.0     main-is: Test.hs     build-depends:-        base >=4.7 && <5,-        hspec >=2.2.1 && <2.3,+        Cabal >=1.18.1.5 && <1.23,+        QuickCheck >=2.8.1 && <2.9,         attoparsec >=0.13.0.1 && <0.14,+        base >=4.7 && <5,+        conduit >=1.2.6.1 && <1.3,+        conduit-extra >=1.1.9.2 && <1.2,         containers >=0.5.5.1 && <0.6,+        cryptohash >=0.11.6 && <0.12,         directory >=1.2.2.0 && <1.3,-        exceptions >=0.8.0.2 && <0.9,-        filepath >=1.4.0.0 && <1.5,-        path >=0.5.3 && <0.6,-        temporary >=1.2.0.3 && <1.3,-        stack >=1.0.2 && <1.1,-        monad-logger >=0.3.16 && <0.4,+        exceptions >=0.8.2.1 && <0.9,+        hspec >=2.2.2 && <2.3,         http-conduit >=2.1.8 && <2.2,-        cryptohash >=0.11.6 && <0.12,-        transformers >=0.4.2.0 && <0.5,-        conduit >=1.2.6.1 && <1.3,-        conduit-extra >=1.1.9.2 && <1.2,+        monad-logger >=0.3.17 && <0.4,+        path >=0.5.3 && <0.6,+        path-io >=0.3.1 && <0.4,         resourcet >=1.1.7 && <1.2,-        Cabal >=1.22.6.0 && <1.23,+        retry >=0.6 && <0.8,+        stack >=1.0.4 && <1.1,+        temporary >=1.2.0.4 && <1.3,         text >=1.2.2.0 && <1.3,-        optparse-applicative >=0.11 && <0.13,-        bytestring >=0.10.6.0 && <0.11,-        QuickCheck >=2.8.1 && <2.9,-        retry >=0.6 && <0.8+        transformers >=0.4.2.0 && <0.5     default-language: Haskell2010     hs-source-dirs: src/test     other-modules:@@ -322,21 +305,21 @@     type: exitcode-stdio-1.0     main-is: IntegrationSpec.hs     build-depends:+        async >=2.1.0 && <2.2,         base >=4.7 && <5,-        temporary >=1.2.0.3 && <1.3,-        hspec >=2.2.1 && <2.3,-        process >=1.2.3.0 && <1.3,-        filepath >=1.4.0.0 && <1.5,-        directory >=1.2.2.0 && <1.3,-        text >=1.2.2.0 && <1.3,-        unix-compat >=0.4.1.4 && <0.5,-        containers >=0.5.5.1 && <0.6,+        bytestring >=0.10.6.0 && <0.11,         conduit >=1.2.6.1 && <1.3,         conduit-extra >=1.1.9.2 && <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.2 && <2.3,+        process >=1.2.3.0 && <1.3,         resourcet >=1.1.7 && <1.2,-        async >=2.0.2 && <2.2,+        temporary >=1.2.0.4 && <1.3,+        text >=1.2.2.0 && <1.3,         transformers >=0.4.2.0 && <0.5,-        bytestring >=0.10.6.0 && <0.11+        unix-compat >=0.4.1.4 && <0.5     default-language: Haskell2010     hs-source-dirs: test/integration test/integration/lib     other-modules:
stack.yaml view
@@ -1,4 +1,4 @@-resolver: lts-4.0+resolver: lts-5.0 image:   containers:     - base: "fpco/ubuntu-with-libgmp:14.04"@@ -10,5 +10,5 @@   packages:     - zlib extra-deps:-# Should be removed once gitrev is updated in stackage (lts-5)-- gitrev-1.2.0+- path-io-0.3.1+- hpack-0.9.0