[commit: ghc] master: Handle unset HOME environment variable more gracefully (2908ae8)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/2908ae8dbe8fd69f8c3ac3dab199026dfc250445/ghc

>---------------------------------------------------------------

commit 2908ae8dbe8fd69f8c3ac3dab199026dfc250445
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Fri Mar 11 10:44:03 2016 +0100

    Handle unset HOME environment variable more gracefully
    
    Test Plan:
      * Validate
      * try `env -i ghc`
      * try `env -i runghc HelloWorld.hs`
    
    Reviewers: austin
    
    Subscribers: thomie, ezyang
    
    Differential Revision: https://phabricator.haskell.org/D1971
    
    GHC Trac Issues: #11678


>---------------------------------------------------------------

2908ae8dbe8fd69f8c3ac3dab199026dfc250445
 compiler/main/DynFlags.hs |  9 +++++----
 compiler/main/Packages.hs |  6 +++---
 compiler/utils/Maybes.hs  | 10 +++++++++-
 3 files changed, 17 insertions(+), 8 deletions(-)

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ce51d3e..2e8af7d 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1046,9 +1046,10 @@ opt_i dflags = sOpt_i (settings dflags)
 -- | The directory for this version of ghc in the user's app directory
 -- (typically something like @~/.ghc/x86_64-linux-7.6.3@)
 --
-versionedAppDir :: DynFlags -> IO FilePath
+versionedAppDir :: DynFlags -> MaybeT IO FilePath
 versionedAppDir dflags = do
-  appdir <- getAppUserDataDirectory (programName dflags)
+  -- Make sure we handle the case the HOME isn't set (see #11678)
+  appdir <- tryMaybeT $ getAppUserDataDirectory (programName dflags)
   return $ appdir </> versionedFilePath dflags
 
 -- | A filepath like @x86_64-linux-7.6.3@ with the platform string to use when
@@ -4334,7 +4335,7 @@ interpretPackageEnv dflags = do
 
     namedEnvPath :: String -> MaybeT IO FilePath
     namedEnvPath name = do
-     appdir <- liftMaybeT $ versionedAppDir dflags
+     appdir <- versionedAppDir dflags
      return $ appdir </> "environments" </> name
 
     probeEnvName :: String -> MaybeT IO FilePath
@@ -4394,7 +4395,7 @@ interpretPackageEnv dflags = do
     findLocalEnvFile :: MaybeT IO FilePath
     findLocalEnvFile = do
         curdir  <- liftMaybeT getCurrentDirectory
-        homedir <- liftMaybeT getHomeDirectory
+        homedir <- tryMaybeT getHomeDirectory
         let probe dir | isDrive dir || dir == homedir
                       = mzero
             probe dir = do
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index decd7a1..2655c45 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -384,11 +384,11 @@ resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig d
 -- NB: This logic is reimplemented in Cabal, so if you change it,
 -- make sure you update Cabal.  (Or, better yet, dump it in the
 -- compiler info so Cabal can use the info.)
-resolvePackageConfig dflags UserPkgConf = handleIO (\_ -> return Nothing) $ do
+resolvePackageConfig dflags UserPkgConf = runMaybeT $ do
   dir <- versionedAppDir dflags
   let pkgconf = dir </> "package.conf.d"
-  exist <- doesDirectoryExist pkgconf
-  return $ if exist then Just pkgconf else Nothing
+  exist <- tryMaybeT $ doesDirectoryExist pkgconf
+  if exist then return pkgconf else mzero
 resolvePackageConfig _ (PkgConfFile name) = return $ Just name
 
 readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig])
diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs
index 83dc9b6..a736e3d 100644
--- a/compiler/utils/Maybes.hs
+++ b/compiler/utils/Maybes.hs
@@ -14,11 +14,13 @@ module Maybes (
         whenIsJust,
         expectJust,
 
-        MaybeT(..), liftMaybeT
+        -- * MaybeT
+        MaybeT(..), liftMaybeT, tryMaybeT
     ) where
 
 import Control.Monad
 import Control.Monad.Trans.Maybe
+import Control.Exception (catch, SomeException(..))
 import Data.Maybe
 
 infixr 4 `orElse`
@@ -65,6 +67,12 @@ orElse = flip fromMaybe
 liftMaybeT :: Monad m => m a -> MaybeT m a
 liftMaybeT act = MaybeT $ Just `liftM` act
 
+-- | Try performing an 'IO' action, failing on error.
+tryMaybeT :: IO a -> MaybeT IO a
+tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler
+  where
+    handler (SomeException _) = return Nothing
+
 {-
 ************************************************************************
 *                                                                      *