ghc/lib/std/System.lhs

   1 % -----------------------------------------------------------------------------
   2 % $Id: System.lhs,v 1.27 2001/01/11 07:04:16 qrczak Exp $
   3 %
   4 % (c) The University of Glasgow, 1994-2000
   5 %
   6
   7 \section[System]{Module @System@}
   8
   9 \begin{code}
  10 {-# OPTIONS -#include "cbits/stgio.h" #-}
  11 module System
  12     (
  13       ExitCode(ExitSuccess,ExitFailure)
  14     , getArgs       -- :: IO [String]
  15     , getProgName   -- :: IO String
  16     , getEnv        -- :: String -> IO String
  17     , system        -- :: String -> IO ExitCode
  18     , exitWith      -- :: ExitCode -> IO a
  19     , exitFailure   -- :: IO a
  20   ) where
  21 \end{code}
  22
  23
  24 #ifndef __HUGS__
  25 \begin{code}
  26 import Prelude
  27 import PrelAddr
  28 import PrelIOBase       ( IOException(..), ioException,
  29                           IOErrorType(..), constructErrorAndFailWithInfo, stToIO )
  30 import PrelPack         ( unpackCString, unpackCStringST, packString )
  31 import PrelByteArr      ( ByteArray )
  32
  33 type PrimByteArray  = ByteArray Int
  34
  35 primUnpackCString :: Addr -> IO String
  36 primUnpackCString s = stToIO ( unpackCStringST s )
  37
  38 primPackString :: String -> PrimByteArray
  39 primPackString s    = packString s
  40
  41 \end{code}
  42
  43 %*********************************************************
  44 %*                                                      *
  45 \subsection{The @ExitCode@ type}
  46 %*                                                      *
  47 %*********************************************************
  48
  49 The $ExitCode$ type defines the exit codes that a program
  50 can return.  $ExitSuccess$ indicates successful termination;
  51 and $ExitFailure code$ indicates program failure
  52 with value {\em code}.  The exact interpretation of {\em code}
  53 is operating-system dependent.  In particular, some values of
  54 {\em code} may be prohibited (e.g. 0 on a POSIX-compliant system).
  55
  56 \begin{code}
  57 data ExitCode = ExitSuccess | ExitFailure Int
  58                 deriving (Eq, Ord, Read, Show)
  59
  60 \end{code}
  61
  62 Computation $getArgs$ returns a list of the program's command
  63 line arguments (not including the program name).
  64
  65 \begin{code}
  66 getArgs                 :: IO [String]
  67 getArgs = return (unpackArgv primArgv primArgc)
  68
  69 foreign import ccall "libHS_cbits.so" "get_prog_argv" unsafe primArgv :: Addr
  70 foreign import ccall "libHS_cbits.so" "get_prog_argc" unsafe primArgc :: Int
  71 \end{code}
  72
  73 Computation $getProgName$ returns the name of the program
  74 as it was invoked.
  75
  76 \begin{code}
  77 getProgName             :: IO String
  78 getProgName = return (unpackProgName primArgv)
  79 \end{code}
  80
  81 Computation $getEnv var$ returns the value
  82 of the environment variable {\em var}.
  83
  84 This computation may fail with
  85 \begin{itemize}
  86 \item $NoSuchThing$
  87 The environment variable does not exist.
  88 \end{itemize}
  89
  90 \begin{code}
  91 getEnv                  :: String -> IO String
  92 getEnv name = do
  93     litstring <- primGetEnv (primPackString name)
  94     if litstring /= nullAddr
  95         then primUnpackCString litstring
  96         else ioException (IOError Nothing NoSuchThing "getEnv"
  97                           "no environment variable" (Just name))
  98
  99 foreign import ccall "libHS_cbits.so" "getenv" unsafe primGetEnv :: PrimByteArray -> IO Addr
 100 \end{code}
 101
 102 Computation $system cmd$ returns the exit code
 103 produced when the operating system processes the command {\em cmd}.
 104
 105 This computation may fail with
 106 \begin{itemize}
 107 \item $PermissionDenied$
 108 The process has insufficient privileges to perform the operation.
 109 \item $ResourceExhausted$
 110 Insufficient resources are available to perform the operation.
 111 \item $UnsupportedOperation$
 112 The implementation does not support system calls.
 113 \end{itemize}
 114
 115 \begin{code}
 116 system                  :: String -> IO ExitCode
 117 system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)
 118 system cmd = do
 119     status <- primSystem (primPackString cmd)
 120     case status of
 121         0  -> return ExitSuccess
 122         -1 -> constructErrorAndFailWithInfo "system" cmd
 123         n  -> return (ExitFailure n)
 124
 125 foreign import ccall "libHS_cbits.so" "systemCmd" unsafe primSystem :: PrimByteArray -> IO Int
 126 \end{code}
 127
 128 @exitWith code@ terminates the program, returning {\em code} to the program's caller.
 129 Before it terminates, any open or semi-closed handles are first closed.
 130
 131 \begin{code}
 132 exitWith                :: ExitCode -> IO a
 133 exitWith ExitSuccess = do
 134     primExit 0
 135     ioException (IOError Nothing OtherError "exitWith" "exit should not return" Nothing)
 136
 137 exitWith (ExitFailure n)
 138   | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing)
 139   | otherwise = do
 140     primExit n
 141     ioException (IOError Nothing OtherError "exitWith" "exit should not return" Nothing)
 142
 143 -- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
 144 -- re-enter Haskell land through finalizers.
 145 foreign import ccall "shutdownHaskellAndExit" primExit :: Int -> IO ()
 146
 147 exitFailure :: IO a
 148 exitFailure = exitWith (ExitFailure 1)
 149 \end{code}
 150
 151
 152 %*********************************************************
 153 %*                                                      *
 154 \subsection{Local utilities}
 155 %*                                                      *
 156 %*********************************************************
 157
 158 \begin{code}
 159 type CHAR_STAR_STAR     = Addr  -- this is all a  HACK
 160 type CHAR_STAR          = Addr
 161
 162 unpackArgv :: CHAR_STAR_STAR -> Int -> [String] -- argv[1 .. argc-1]
 163 unpackArgv argv argc = unpack 1
 164   where
 165    unpack :: Int -> [String]
 166    unpack n
 167      | n >= argc = []
 168      | otherwise =
 169          case (indexAddrOffAddr argv n) of
 170            item -> unpackCString item : unpack (n + 1)
 171
 172 unpackProgName  :: CHAR_STAR_STAR        -> String   -- argv[0]
 173 unpackProgName argv
 174   = case (indexAddrOffAddr argv 0) of { prog ->
 175     de_slash [] (unpackCString prog) }
 176   where
 177     -- re-start accumulating at every '/'
 178     de_slash :: String -> String -> String
 179     de_slash  acc []       = reverse acc
 180     de_slash _acc ('/':xs) = de_slash []      xs
 181     de_slash  acc (x:xs)   = de_slash (x:acc) xs
 182 \end{code}
 183
 184 #else
 185
 186 \begin{code}
 187 -----------------------------------------------------------------------------
 188 -- Standard Library: System operations
 189 --
 190 -- Warning: the implementation of these functions in Hugs 98 is very weak.
 191 -- The functions themselves are best suited to uses in compiled programs,
 192 -- and not to use in an interpreter-based environment like Hugs.
 193 --
 194 -- Suitable for use with Hugs 98
 195 -----------------------------------------------------------------------------
 196 import PrelPrim ( primGetRawArgs
 197                 , primGetEnv
 198                 , prelCleanupAfterRunAction
 199                 , copy_String_to_cstring
 200                 , readIORef
 201                 , nh_stderr
 202                 , nh_stdout
 203                 , nh_stdin
 204                 , nh_exitwith
 205                 , nh_flush
 206                 , nh_close
 207                 , nh_system
 208                 , nh_free
 209                 , nh_getPID
 210                 )
 211
 212
 213 data ExitCode = ExitSuccess | ExitFailure Int
 214                 deriving (Eq, Ord, Read, Show)
 215
 216 getArgs                     :: IO [String]
 217 getArgs                      = primGetRawArgs >>= \rawargs ->
 218                                return (tail rawargs)
 219
 220 getProgName                 :: IO String
 221 getProgName                  = primGetRawArgs >>= \rawargs ->
 222                                return (head rawargs)
 223
 224 getEnv                      :: String -> IO String
 225 getEnv                       = primGetEnv
 226
 227 exitFailure                 :: IO a
 228 exitFailure                  = exitWith (ExitFailure 1)
 229
 230 toExitCode                  :: Int -> ExitCode
 231 toExitCode 0                 = ExitSuccess
 232 toExitCode n                 = ExitFailure n
 233
 234 fromExitCode                :: ExitCode -> Int
 235 fromExitCode ExitSuccess     = 0
 236 fromExitCode (ExitFailure n) = n
 237
 238 -- see comment in Prelude.hs near primRunIO_hugs_toplevel
 239 exitWith :: ExitCode -> IO a
 240 exitWith c
 241    = do cleanup_action <- readIORef prelCleanupAfterRunAction
 242         case cleanup_action of
 243            Just xx -> xx
 244            Nothing -> return ()
 245         nh_stderr >>= nh_flush
 246         nh_stdout >>= nh_flush
 247         nh_stdin  >>= nh_close
 248         nh_exitwith (fromExitCode c)
 249         (ioException . IOError) "System.exitWith: should not return"
 250
 251 system :: String -> IO ExitCode
 252 system cmd
 253    | null cmd
 254    = (ioException.IOError) "System.system: null command"
 255    | otherwise
 256    = do str    <- copy_String_to_cstring cmd
 257         status <- nh_system str
 258         nh_free str
 259         case status of
 260            0  -> return ExitSuccess
 261            n  -> return (ExitFailure n)
 262
 263 getPID :: IO Int
 264 getPID
 265    = nh_getPID
 266
 267 -----------------------------------------------------------------------------
 268 \end{code}
 269 #endif