Environment.hs

{-# OPTIONS_JHC -fffi #-}
module System.Environment
    (
      getArgs,       -- :: IO [String]
      getProgName,   -- :: IO String
      getEnv,        -- :: String -> IO String
      getEnvironment -- :: IO [(String,String)]
  ) where

import Foreign.C.String
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.C.Types
import qualified Jhc.Options

getArgs     :: IO [String]
getProgName :: IO String
getEnv      :: String -> IO String

getProgName = case Jhc.Options.target of
    Jhc.Options.GhcHs -> ghc_getProgName
    _ -> peek ajhc_progname >>= peekCString

getArgs = case Jhc.Options.target of
    Jhc.Options.GhcHs -> ghc_getArgs
    _ -> do
        argc <- peek ajhc_argc
        argv <- peek ajhc_argv
        let f n = peekElemOff argv n >>= peekCString
        mapM f [0 .. fromIntegral argc - 1]

getEnv s = withCString s c_getenv >>= \p ->
    if p == nullPtr then fail ("getEnv: " ++ show s)  else peekCString p

foreign import unsafe ccall "stdlib.h getenv" c_getenv :: Ptr CChar -> IO (Ptr CChar)

foreign import ccall "&jhc_progname" ajhc_progname :: Ptr CString
foreign import ccall "&jhc_argc" ajhc_argc :: Ptr CInt
foreign import ccall "&jhc_argv" ajhc_argv :: Ptr (Ptr CString)

ghc_getArgs :: IO [String]
ghc_getArgs =
    alloca $ \ p_argc ->
    alloca $ \ p_argv -> do
        getProgArgv p_argc p_argv
        p    <- peek p_argc
        argv <- peek p_argv
        let f n = peekElemOff argv n >>= peekCString
        mapM f [1 .. fromIntegral p - 1]

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

ghc_getProgName :: IO String
ghc_getProgName =
  alloca $ \ p_argc ->
  alloca $ \ p_argv -> do
     getProgArgv p_argc p_argv
     argv <- peek p_argv
     peekElemOff argv 0 >>= peekCString

-- |'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)]
getEnvironment = do
   pBlock <- peek c_environ
   if pBlock == nullPtr then return []
    else do
      stuff <- peekArray0 nullPtr pBlock >>= mapM peekCString
      return (map divvy stuff)
  where
   divvy str =
      case break (=='=') str of
        (xs,[])        -> (xs,[]) -- don't barf (like Posix.getEnvironment)
        (name,_:value) -> (name,value)

foreign import ccall "&environ" c_environ :: Ptr (Ptr CString)