{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  System.Environment
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Miscellaneous information about the system environment.
--
-----------------------------------------------------------------------------

module System.Environment
    (
      getArgs,
      getProgName,
#if !defined(javascript_HOST_ARCH)
      executablePath,
#endif
      getExecutablePath,
      getEnv,
      lookupEnv,
      setEnv,
      unsetEnv,
      withArgs,
      withProgName,
      getEnvironment,
  ) where

import Foreign
import Foreign.C
import System.IO.Error (mkIOError)
import Control.Exception.Base (bracket_, throwIO)
#if defined(mingw32_HOST_OS)
import Control.Exception.Base (bracket)
#endif
-- import GHC.IO
import GHC.IO.Exception
import qualified GHC.Foreign as GHC
import Control.Monad
#if defined(mingw32_HOST_OS)
import GHC.IO.Encoding (argvEncoding)
import GHC.Windows
#else
import GHC.IO.Encoding (getFileSystemEncoding, argvEncoding)
import System.Posix.Internals (withFilePath)
#endif

import System.Environment.ExecutablePath

#if defined(mingw32_HOST_OS)
# 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
#endif

#include "HsBaseConfig.h"

-- ---------------------------------------------------------------------------
-- getArgs, getProgName, getEnv

-- | Computation 'getArgs' returns a list of the program's command
-- line arguments (not including the program name).
getArgs :: IO [String]
getArgs :: IO [String]
getArgs =
  (Ptr CInt -> IO [String]) -> IO [String]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO [String]) -> IO [String])
-> (Ptr CInt -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \ Ptr CInt
p_argc ->
  (Ptr (Ptr (Ptr CChar)) -> IO [String]) -> IO [String]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr (Ptr CChar)) -> IO [String]) -> IO [String])
-> (Ptr (Ptr (Ptr CChar)) -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr (Ptr CChar))
p_argv -> do
   Ptr CInt -> Ptr (Ptr (Ptr CChar)) -> IO ()
getProgArgv Ptr CInt
p_argc Ptr (Ptr (Ptr CChar))
p_argv
   Int
p    <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
p_argc
   Ptr (Ptr CChar)
argv <- Ptr (Ptr (Ptr CChar)) -> IO (Ptr (Ptr CChar))
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr (Ptr CChar))
p_argv
   TextEncoding
enc <- IO TextEncoding
argvEncoding
   Int -> Ptr (Ptr CChar) -> IO [Ptr CChar]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Ptr (Ptr CChar) -> Int -> Ptr (Ptr CChar)
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr (Ptr CChar)
argv Int
1) IO [Ptr CChar] -> ([Ptr CChar] -> IO [String]) -> IO [String]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Ptr CChar -> IO String) -> [Ptr CChar] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TextEncoding -> Ptr CChar -> IO String
GHC.peekCString TextEncoding
enc)


foreign import ccall unsafe "getProgArgv"
  getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()

{-|
Computation 'getProgName' returns the name of the program as it was
invoked.

However, this is hard-to-impossible to implement on some non-Unix
OSes, so instead, for maximum portability, we just return the leafname
of the program as invoked. Even then there are some differences
between platforms: on Windows, for example, a program invoked as foo
is probably really @FOO.EXE@, and that is what 'getProgName' will return.
-}
getProgName :: IO String
-- Ignore the arguments to hs_init on Windows for the sake of Unicode compat
getProgName :: IO String
getProgName =
  (Ptr CInt -> IO String) -> IO String
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO String) -> IO String)
-> (Ptr CInt -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \ Ptr CInt
p_argc ->
  (Ptr (Ptr (Ptr CChar)) -> IO String) -> IO String
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr (Ptr CChar)) -> IO String) -> IO String)
-> (Ptr (Ptr (Ptr CChar)) -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr (Ptr CChar))
p_argv -> do
     Ptr CInt -> Ptr (Ptr (Ptr CChar)) -> IO ()
getProgArgv Ptr CInt
p_argc Ptr (Ptr (Ptr CChar))
p_argv
     Ptr (Ptr CChar)
argv <- Ptr (Ptr (Ptr CChar)) -> IO (Ptr (Ptr CChar))
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr (Ptr CChar))
p_argv
     Ptr (Ptr CChar) -> IO String
unpackProgName Ptr (Ptr CChar)
argv

unpackProgName  :: Ptr (Ptr CChar) -> IO String   -- argv[0]
unpackProgName :: Ptr (Ptr CChar) -> IO String
unpackProgName Ptr (Ptr CChar)
argv = do
  TextEncoding
enc <- IO TextEncoding
argvEncoding
  String
s <- Ptr (Ptr CChar) -> Int -> IO (Ptr CChar)
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr (Ptr CChar)
argv Int
0 IO (Ptr CChar) -> (Ptr CChar -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TextEncoding -> Ptr CChar -> IO String
GHC.peekCString TextEncoding
enc
  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
basename String
s)

basename :: FilePath -> FilePath
basename :: String -> String
basename String
f = String -> String -> String
go String
f String
f
 where
  go :: String -> String -> String
go String
acc [] = String
acc
  go String
acc (Char
x:String
xs)
    | Char -> Bool
isPathSeparator Char
x = String -> String -> String
go String
xs String
xs
    | Bool
otherwise         = String -> String -> String
go String
acc String
xs

  isPathSeparator :: Char -> Bool
  isPathSeparator :: Char -> Bool
isPathSeparator Char
'/'  = Bool
True
#if defined(mingw32_HOST_OS)
  isPathSeparator Char
'\\' = Bool
True
#endif
  isPathSeparator Char
_    = Bool
False


-- | Computation 'getEnv' @var@ returns the value
-- of the environment variable @var@. For the inverse, the
-- `System.Environment.setEnv` function can be used.
--
-- This computation may fail with:
--
--  * 'System.IO.Error.isDoesNotExistError' if the environment variable
--    does not exist.

getEnv :: String -> IO String
getEnv :: String -> IO String
getEnv String
name = String -> IO (Maybe String)
lookupEnv String
name IO (Maybe String) -> (Maybe String -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
forall {b}. IO b
handleError String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
  where
#if defined(mingw32_HOST_OS)
    handleError :: IO b
handleError = do
        DWORD
err <- IO DWORD
c_GetLastError
        if DWORD
err DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
eRROR_ENVVAR_NOT_FOUND
            then String -> IO b
forall a. String -> IO a
ioe_missingEnvVar String
name
            else String -> IO b
forall a. String -> IO a
throwGetLastError String
"getEnv"

eRROR_ENVVAR_NOT_FOUND :: DWORD
eRROR_ENVVAR_NOT_FOUND :: DWORD
eRROR_ENVVAR_NOT_FOUND = DWORD
203

foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
  c_GetLastError:: IO DWORD

#else
    handleError = ioe_missingEnvVar name
#endif

-- | Return the value of the environment variable @var@, or @Nothing@ if
-- there is no such value.
--
-- For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'.
--
-- @since 4.6.0.0
lookupEnv :: String -> IO (Maybe String)
#if defined(mingw32_HOST_OS)
lookupEnv :: String -> IO (Maybe String)
lookupEnv String
name = String -> (Ptr CWchar -> IO (Maybe String)) -> IO (Maybe String)
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
name ((Ptr CWchar -> IO (Maybe String)) -> IO (Maybe String))
-> (Ptr CWchar -> IO (Maybe String)) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
s -> Ptr CWchar -> DWORD -> IO (Maybe String)
try_size Ptr CWchar
s DWORD
256
  where
    try_size :: Ptr CWchar -> DWORD -> IO (Maybe String)
try_size Ptr CWchar
s DWORD
size = Int -> (Ptr CWchar -> IO (Maybe String)) -> IO (Maybe String)
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (DWORD -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral DWORD
size) ((Ptr CWchar -> IO (Maybe String)) -> IO (Maybe String))
-> (Ptr CWchar -> IO (Maybe String)) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
p_value -> do
      DWORD
res <- Ptr CWchar -> Ptr CWchar -> DWORD -> IO DWORD
c_GetEnvironmentVariable Ptr CWchar
s Ptr CWchar
p_value DWORD
size
      case DWORD
res of
        DWORD
0 -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
        DWORD
_ | DWORD
res DWORD -> DWORD -> Bool
forall a. Ord a => a -> a -> Bool
> DWORD
size -> Ptr CWchar -> DWORD -> IO (Maybe String)
try_size Ptr CWchar
s DWORD
res -- Rare: size increased between calls to GetEnvironmentVariable
          | Bool
otherwise  -> Ptr CWchar -> IO String
peekCWString Ptr CWchar
p_value IO String -> (String -> IO (Maybe String)) -> IO (Maybe String)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> (String -> Maybe String) -> String -> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just

foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentVariableW"
  c_GetEnvironmentVariable :: LPWSTR -> LPWSTR -> DWORD -> IO DWORD
#else
lookupEnv name =
    withCString name $ \s -> do
      litstring <- c_getenv s
      if litstring /= nullPtr
        then do enc <- getFileSystemEncoding
                result <- GHC.peekCString enc litstring
                return $ Just result
        else return Nothing

foreign import ccall unsafe "getenv"
   c_getenv :: CString -> IO (Ptr CChar)
#endif

ioe_missingEnvVar :: String -> IO a
ioe_missingEnvVar :: forall a. String -> IO a
ioe_missingEnvVar String
name = IOError -> IO a
forall a. IOError -> IO a
ioException (Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
NoSuchThing String
"getEnv"
    String
"no environment variable" Maybe CInt
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
name))

-- | @setEnv name value@ sets the specified environment variable to @value@.
--
-- Early versions of this function operated under the mistaken belief that
-- setting an environment variable to the /empty string/ on Windows removes
-- that environment variable from the environment.  For the sake of
-- compatibility, it adopted that behavior on POSIX.  In particular
--
-- @
-- setEnv name \"\"
-- @
--
-- has the same effect as
--
-- @
-- `unsetEnv` name
-- @
--
-- If you'd like to be able to set environment variables to blank strings,
-- use `System.Environment.Blank.setEnv`.
--
-- Throws `Control.Exception.IOException` if @name@ is the empty string or
-- contains an equals sign.
--
-- @since 4.7.0.0
setEnv :: String -> String -> IO ()
setEnv :: String -> String -> IO ()
setEnv String
key_ String
value_
  | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
key       = IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
InvalidArgument String
"setEnv" Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
  | Char
'=' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
key = IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
InvalidArgument String
"setEnv" Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
  | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
value     = String -> IO ()
unsetEnv String
key
  | Bool
otherwise      = String -> String -> IO ()
setEnv_ String
key String
value
  where
    key :: String
key   = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\NUL') String
key_
    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 ()
#if defined(mingw32_HOST_OS)
setEnv_ :: String -> String -> IO ()
setEnv_ String
key String
value = String -> (Ptr CWchar -> IO ()) -> IO ()
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
key ((Ptr CWchar -> IO ()) -> IO ()) -> (Ptr CWchar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
k -> String -> (Ptr CWchar -> IO ()) -> IO ()
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
value ((Ptr CWchar -> IO ()) -> IO ()) -> (Ptr CWchar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
v -> do
  Bool
success <- Ptr CWchar -> Ptr CWchar -> IO Bool
c_SetEnvironmentVariable Ptr CWchar
k Ptr CWchar
v
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (String -> IO ()
forall a. String -> IO a
throwGetLastError String
"setEnv")

foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool
#else

-- NOTE: The 'setenv()' function is not available on all systems, hence we use
-- 'putenv()'.  This leaks memory, but so do common implementations of
-- 'setenv()' (AFAIK).
setEnv_ k v = putEnv (k ++ "=" ++ v)

putEnv :: String -> IO ()
putEnv keyvalue = do
  s <- getFileSystemEncoding >>= (`GHC.newCString` keyvalue)
  -- IMPORTANT: Do not free `s` after calling putenv!
  --
  -- According to SUSv2, the string passed to putenv becomes part of the
  -- environment.
  throwErrnoIf_ (/= 0) "putenv" (c_putenv s)

foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt
#endif

-- | @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 ()
#if defined(mingw32_HOST_OS)
unsetEnv :: String -> IO ()
unsetEnv String
key = String -> (Ptr CWchar -> IO ()) -> IO ()
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
key ((Ptr CWchar -> IO ()) -> IO ()) -> (Ptr CWchar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
k -> do
  Bool
success <- Ptr CWchar -> Ptr CWchar -> IO Bool
c_SetEnvironmentVariable Ptr CWchar
k Ptr CWchar
forall a. Ptr a
nullPtr
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- We consider unsetting an environment variable that does not exist not as
    -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.
    DWORD
err <- IO DWORD
c_GetLastError
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DWORD
err DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
eRROR_ENVVAR_NOT_FOUND) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
forall a. String -> IO a
throwGetLastError String
"unsetEnv"
#else

#if defined(HAVE_UNSETENV)
unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)
foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> IO CInt
#else
unsetEnv key = setEnv_ key ""
#endif

#endif

{-|
'withArgs' @args act@ - while executing action @act@, have 'getArgs'
return @args@.
-}
withArgs :: [String] -> IO a -> IO a
withArgs :: forall a. [String] -> IO a -> IO a
withArgs [String]
xs IO a
act = do
   String
p <- IO String
System.Environment.getProgName
   [String] -> IO a -> IO a
forall a. [String] -> IO a -> IO a
withArgv (String
pString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs) IO a
act

{-|
'withProgName' @name act@ - while executing action @act@,
have 'getProgName' return @name@.
-}
withProgName :: String -> IO a -> IO a
withProgName :: forall a. String -> IO a -> IO a
withProgName String
nm IO a
act = do
   [String]
xs <- IO [String]
System.Environment.getArgs
   [String] -> IO a -> IO a
forall a. [String] -> IO a -> IO a
withArgv (String
nmString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs) IO a
act

-- Worker routine which marshals and replaces an argv vector for
-- the duration of an action.

withArgv :: [String] -> IO a -> IO a
withArgv :: forall a. [String] -> IO a -> IO a
withArgv = [String] -> IO a -> IO a
forall a. [String] -> IO a -> IO a
withProgArgv

withProgArgv :: [String] -> IO a -> IO a
withProgArgv :: forall a. [String] -> IO a -> IO a
withProgArgv [String]
new_args IO a
act = do
  String
pName <- IO String
System.Environment.getProgName
  [String]
existing_args <- IO [String]
System.Environment.getArgs
  IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ ([String] -> IO ()
setProgArgv [String]
new_args)
           ([String] -> IO ()
setProgArgv (String
pNameString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
existing_args))
           IO a
act

setProgArgv :: [String] -> IO ()
setProgArgv :: [String] -> IO ()
setProgArgv [String]
argv = do
  TextEncoding
enc <- IO TextEncoding
argvEncoding
  TextEncoding
-> [String] -> (Int -> Ptr (Ptr CChar) -> IO ()) -> IO ()
forall a.
TextEncoding
-> [String] -> (Int -> Ptr (Ptr CChar) -> IO a) -> IO a
GHC.withCStringsLen TextEncoding
enc [String]
argv ((Int -> Ptr (Ptr CChar) -> IO ()) -> IO ())
-> (Int -> Ptr (Ptr CChar) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
len Ptr (Ptr CChar)
css ->
    CInt -> Ptr (Ptr CChar) -> IO ()
c_setProgArgv (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) Ptr (Ptr CChar)
css

-- setProgArgv copies the arguments
foreign import ccall unsafe "setProgArgv"
  c_setProgArgv  :: CInt -> Ptr CString -> IO ()

-- |'getEnvironment' retrieves the entire environment as a
-- list of @(key,value)@ pairs.
--
-- If an environment entry does not contain an @\'=\'@ character,
-- the @key@ is the whole entry and the @value@ is the empty string.
getEnvironment :: IO [(String, String)]

#if defined(mingw32_HOST_OS)
getEnvironment :: IO [(String, String)]
getEnvironment = IO (Ptr CWchar)
-> (Ptr CWchar -> IO Bool)
-> (Ptr CWchar -> IO [(String, String)])
-> IO [(String, String)]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Ptr CWchar)
c_GetEnvironmentStrings Ptr CWchar -> IO Bool
c_FreeEnvironmentStrings ((Ptr CWchar -> IO [(String, String)]) -> IO [(String, String)])
-> (Ptr CWchar -> IO [(String, String)]) -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
pBlock ->
    if Ptr CWchar
pBlock Ptr CWchar -> Ptr CWchar -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CWchar
forall a. Ptr a
nullPtr then [(String, String)] -> IO [(String, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
     else Ptr CWchar -> IO [(String, String)]
go Ptr CWchar
pBlock
  where
    go :: Ptr CWchar -> IO [(String, String)]
go Ptr CWchar
pBlock = do
        -- The block is terminated by a null byte where there
        -- should be an environment variable of the form X=Y
        CWchar
c <- Ptr CWchar -> IO CWchar
forall a. Storable a => Ptr a -> IO a
peek Ptr CWchar
pBlock
        if CWchar
c CWchar -> CWchar -> Bool
forall a. Eq a => a -> a -> Bool
== CWchar
0 then [(String, String)] -> IO [(String, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
         else do
          -- Seek the next pair (or terminating null):
          Ptr CWchar
pBlock' <- Ptr CWchar -> Bool -> IO (Ptr CWchar)
forall {b} {b}. Ptr b -> Bool -> IO (Ptr b)
seekNull Ptr CWchar
pBlock Bool
False
          -- We now know the length in bytes, but ignore it when
          -- getting the actual String:
          String
str <- Ptr CWchar -> IO String
peekCWString Ptr CWchar
pBlock
          ([(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)
divvy String
str (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:) (IO [(String, String)] -> IO [(String, String)])
-> IO [(String, String)] -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ Ptr CWchar -> IO [(String, String)]
go Ptr CWchar
pBlock'

    -- Returns pointer to the byte *after* the next null
    seekNull :: Ptr b -> Bool -> IO (Ptr b)
seekNull Ptr b
pBlock Bool
done = do
        let pBlock' :: Ptr b
pBlock' = Ptr b
pBlock Ptr b -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` CWchar -> Int
forall a. Storable a => a -> Int
sizeOf (CWchar
forall a. HasCallStack => a
undefined :: CWchar)
        if Bool
done then Ptr b -> IO (Ptr b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr b
forall a. Ptr a
pBlock'
         else do
           Word8
c <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek Ptr Word8
forall a. Ptr a
pBlock'
           Ptr b -> Bool -> IO (Ptr b)
seekNull Ptr b
forall a. Ptr a
pBlock' (Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== (Word8
0 :: Word8 ))

foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentStringsW"
  c_GetEnvironmentStrings :: IO (Ptr CWchar)

foreign import WINDOWS_CCONV unsafe "windows.h FreeEnvironmentStringsW"
  c_FreeEnvironmentStrings :: Ptr CWchar -> IO Bool
#else
getEnvironment = do
   pBlock <- getEnvBlock
   if pBlock == nullPtr then return []
    else do
      enc <- getFileSystemEncoding
      stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString enc)
      return (map divvy stuff)

foreign import ccall unsafe "__hscore_environ"
  getEnvBlock :: IO (Ptr CString)
#endif

divvy :: String -> (String, String)
divvy :: String -> (String, String)
divvy String
str =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'=') String
str of
    (String
xs,[])        -> (String
xs,[]) -- don't barf (like Posix.getEnvironment)
    (String
name,Char
_:String
value) -> (String
name,String
value)