Merge pull request #3697 from ezyang/pr/env-haskell-dist-dir

Fix #3483, set HASKELL_DIST_DIR

Cabal/Distribution/Compat/Environment.hs

@@ -3,15 +3,24 @@
 {-# OPTIONS_HADDOCK hide #-}
 
 module Distribution.Compat.Environment
-       ( getEnvironment, lookupEnv, setEnv )
+       ( getEnvironment, lookupEnv, setEnv, unsetEnv )
        where
 
 import Prelude ()
 import Distribution.Compat.Prelude
 
+#ifndef mingw32_HOST_OS
+#if __GLASGOW_HASKELL__ < 708
+import Foreign.C.Error (throwErrnoIf_)
+#endif
+#endif
+
 import qualified System.Environment as System
 #if __GLASGOW_HASKELL__ >= 706
 import System.Environment (lookupEnv)
+#if __GLASGOW_HASKELL__ >= 708
+import System.Environment (unsetEnv)
+#endif
 #else
 import Distribution.Compat.Exception (catchIO)
 #endif
@@ -51,9 +60,7 @@ lookupEnv name = (Just `fmap` System.getEnv name) `catchIO` const (return Nothin
 -- Throws `Control.Exception.IOException` if either @name@ or @value@ is the
 -- empty string or contains an equals sign.
 setEnv :: String -> String -> IO ()
-setEnv key value_
-  | null value = error "Distribution.Compat.setEnv: empty string"
-  | otherwise  = setEnv_ key value
+setEnv key value_ = setEnv_ key value
   where
     -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We
     -- still strip it manually so that the null check above succeeds if a value
@@ -88,3 +95,34 @@ setEnv_ key value = do
 foreign import ccall unsafe "setenv"
    c_setenv :: CString -> CString -> CInt -> IO CInt
 #endif /* mingw32_HOST_OS */
+
+#if __GLASGOW_HASKELL__ < 708
+
+-- | @unsetEnv name@ removes the specified environment variable from the
+-- environment of the current process.
+--
+-- Throws `Control.Exception.IOException` if @name@ is the empty string or
+-- contains an equals sign.
+--
+-- @since 4.7.0.0
+unsetEnv :: String -> IO ()
+#ifdef mingw32_HOST_OS
+unsetEnv key = withCWString key $ \k -> do
+  success <- c_SetEnvironmentVariable k nullPtr
+  unless success $ do
+    -- We consider unsetting an environment variable that does not exist not as
+    -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.
+    err <- c_GetLastError
+    unless (err == eRROR_ENVVAR_NOT_FOUND) $ do
+      throwGetLastError "unsetEnv"
+#else
+unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)
+#if __GLASGOW_HASKELL__ > 706
+foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> IO CInt
+#else
+-- HACK: We hope very hard that !UNSETENV_RETURNS_VOID
+foreign import ccall unsafe "unsetenv" c_unsetenv :: CString -> IO CInt
+#endif
+#endif
+
+#endif

cabal-install/Distribution/Client/SetupWrapper.hs

@@ -80,7 +80,7 @@ import Distribution.Simple.Utils
          , copyFileVerbose, rewriteFile, intercalate )
 import Distribution.Client.Utils
          ( inDir, tryCanonicalizePath
-         , existsAndIsMoreRecentThan, moreRecentFile
+         , existsAndIsMoreRecentThan, moreRecentFile, withEnv
 #if mingw32_HOST_OS
          , canonicalizePathNoThrow
 #endif
@@ -304,7 +304,8 @@ internalSetupMethod verbosity options _ bt mkargs = do
   info verbosity $ "Using internal setup method with build-type " ++ show bt
                 ++ " and args:\n  " ++ show args
   inDir (useWorkingDir options) $
-    buildTypeAction bt args
+    withEnv "HASKELL_DIST_DIR" (useDistPref options) $
+      buildTypeAction bt args
 
 buildTypeAction :: BuildType -> ([String] -> IO ())
 buildTypeAction Simple    = Simple.defaultMainArgs
@@ -334,7 +335,8 @@ selfExecSetupMethod verbosity options _pkg bt mkargs = do
 
   searchpath <- programSearchPathAsPATHVar
                 (getProgramSearchPath (useProgramConfig options))
-  env        <- getEffectiveEnvironment [("PATH", Just searchpath)]
+  env        <- getEffectiveEnvironment [("PATH", Just searchpath)
+                                        ,("HASKELL_DIST_DIR", Just (useDistPref options))]
 
   process <- runProcess path args
              (useWorkingDir options) env Nothing
@@ -687,7 +689,8 @@ externalSetupMethod verbosity options pkg bt mkargs = do
       doInvoke path' = do
         searchpath <- programSearchPathAsPATHVar
                       (getProgramSearchPath (useProgramConfig options'))
-        env        <- getEffectiveEnvironment [("PATH", Just searchpath)]
+        env        <- getEffectiveEnvironment [("PATH", Just searchpath)
+                                              ,("HASKELL_DIST_DIR", Just (useDistPref options))]
 
         process <- runProcess path' args
                    (useWorkingDir options') env Nothing

cabal-install/Distribution/Client/Utils.hs

@@ -3,7 +3,7 @@
 module Distribution.Client.Utils ( MergeResult(..)
                                  , mergeBy, duplicates, duplicatesBy
                                  , readMaybe
-                                 , inDir, logDirChange
+                                 , inDir, withEnv, logDirChange
                                  , determineNumJobs, numberOfProcessors
                                  , removeExistingFile
                                  , withTempFileName
@@ -18,6 +18,7 @@ module Distribution.Client.Utils ( MergeResult(..)
                                  , relaxEncodingErrors)
        where
 
+import Distribution.Compat.Environment ( lookupEnv, setEnv, unsetEnv )
 import Distribution.Compat.Exception   ( catchIO )
 import Distribution.Compat.Time ( getModTime )
 import Distribution.Simple.Setup       ( Flag(..) )
@@ -139,6 +140,19 @@ inDir (Just d) m = do
   setCurrentDirectory d
   m `Exception.finally` setCurrentDirectory old
 
+-- | Executes the action with an environment variable set to some
+-- value.
+--
+-- Warning: This operation is NOT thread-safe, because current
+-- environment is a process-global concept.
+withEnv :: String -> String -> IO a -> IO a
+withEnv k v m = do
+  mb_old <- lookupEnv k
+  setEnv k v
+  m `Exception.finally` (case mb_old of
+    Nothing -> unsetEnv k
+    Just old -> setEnv k old)
+
 -- | Log directory change in 'make' compatible syntax
 logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a
 logDirChange _ Nothing m = m