{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_HADDOCK hide #-}

module Distribution.Compat.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv)
where

import Distribution.Compat.Prelude
import Prelude ()
import qualified Prelude

import System.Environment (lookupEnv, unsetEnv)
import qualified System.Environment as System

import Distribution.Compat.Stack

#ifdef mingw32_HOST_OS
import Foreign.C
import GHC.Windows
#else
import Foreign.C.Types
import Foreign.C.String
import Foreign.C.Error (throwErrnoIfMinus1_)
import System.Posix.Internals ( withFilePath )
#endif /* mingw32_HOST_OS */

getEnvironment :: IO [(String, String)]
#ifdef mingw32_HOST_OS
-- On Windows, the names of environment variables are case-insensitive, but are
-- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise
-- them.
getEnvironment :: IO [(String, String)]
getEnvironment = ([(String, String)] -> [(String, String)])
-> IO [(String, String)] -> IO [(String, String)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(String, String)] -> [(String, String)]
forall {b}. [(String, b)] -> [(String, b)]
upcaseVars IO [(String, String)]
System.getEnvironment
  where
    upcaseVars :: [(String, b)] -> [(String, b)]
upcaseVars = ((String, b) -> (String, b)) -> [(String, b)] -> [(String, b)]
forall a b. (a -> b) -> [a] -> [b]
map (String, b) -> (String, b)
forall {b}. (String, b) -> (String, b)
upcaseVar
    upcaseVar :: (String, b) -> (String, b)
upcaseVar (String
var, b
val) = ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
var, b
val)
#else
getEnvironment = System.getEnvironment
#endif

-- | @setEnv name value@ sets the specified environment variable to @value@.
--
-- Throws `Control.Exception.IOException` if either @name@ or @value@ is the
-- empty string or contains an equals sign.
setEnv :: String -> String -> IO ()
setEnv :: String -> String -> IO ()
setEnv String
key String
value_ = String -> String -> IO ()
setEnv_ String
key String
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
    -- starts with NUL.
    value :: String
value = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\NUL') String
value_

setEnv_ :: String -> String -> IO ()

#ifdef mingw32_HOST_OS

setEnv_ :: String -> String -> IO ()
setEnv_ String
key String
value = String -> (CWString -> IO ()) -> IO ()
forall a. String -> (CWString -> IO a) -> IO a
withCWString String
key ((CWString -> IO ()) -> IO ()) -> (CWString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CWString
k -> String -> (CWString -> IO ()) -> IO ()
forall a. String -> (CWString -> IO a) -> IO a
withCWString String
value ((CWString -> IO ()) -> IO ()) -> (CWString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CWString
v -> do
  Bool
success <- CWString -> CWString -> IO Bool
c_SetEnvironmentVariable CWString
k CWString
v
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (String -> IO ()
forall a. String -> IO a
throwGetLastError String
"setEnv")
 where
  CallStack
_ = CallStack
HasCallStack => CallStack
callStack -- TODO: attach CallStack to exception

{- FOURMOLU_DISABLE -}
# if defined(i386_HOST_ARCH)
#  define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
#  define WINDOWS_CCONV ccall
# else
#  error Unknown mingw32 arch
# endif /* i386_HOST_ARCH */

foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> Prelude.IO Bool
#else
setEnv_ key value = do
  withFilePath key $ \ keyP ->
    withFilePath value $ \ valueP ->
      throwErrnoIfMinus1_ "setenv" $
        c_setenv keyP valueP (fromIntegral (fromEnum True))
 where
  _ = callStack -- TODO: attach CallStack to exception

foreign import ccall unsafe "setenv"
   c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt
#endif /* mingw32_HOST_OS */
{- FOURMOLU_ENABLE -}