Commit 9cb6a994 authored by Edward Z. Yang's avatar Edward Z. Yang Committed by GitHub
Browse files

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

Fix #3483, set HASKELL_DIST_DIR
parents d60397f5 a0efec0b
......@@ -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
......@@ -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
......
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment