ghc/lib/ghc/IOBase.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4
   5 \section[IOBase]{Module @IOBase@}
   6
   7 Definitions for the @IO@ monad and its friends.  Everything is exported
   8 concretely; the @IO@ module itself exports abstractly.
   9
  10 \begin{code}
  11 {-# OPTIONS -fno-implicit-prelude #-}
  12 #include "error.h"
  13
  14 module IOBase where
  15
  16 import STBase
  17 import UnsafeST
  18 import PrelTup
  19 import Foreign
  20 import PackedString     ( unpackCString )
  21 import PrelBase
  22 import ArrBase  ( ByteArray(..), MutableVar(..) )
  23 import PrelRead
  24
  25 import GHC
  26
  27 infixr 1 `thenIO_Prim`, `seqIO_Prim`
  28 \end{code}
  29
  30 %*********************************************************
  31 %*                                                      *
  32 \subsection{The @IO@ monad}
  33 %*                                                      *
  34 %*********************************************************
  35
  36 \begin{code}
  37 newtype IO a = IO (PrimIO (Either IOError a))
  38
  39 instance  Functor IO where
  40    map f x = x >>= (return . f)
  41
  42 instance  Monad IO  where
  43     {-# INLINE return #-}
  44     {-# INLINE (>>)   #-}
  45     {-# INLINE (>>=)  #-}
  46     m >> k      =  m >>= \ _ -> k
  47     return x    = IO $ ST $ \ s@(S# _) -> (Right x, s)
  48
  49     (IO (ST m)) >>= k =
  50         IO (ST ( \ s ->
  51         let  (r, new_s) = m s  in
  52         case r of
  53           Left err -> (Left err, new_s)
  54           Right  x -> case (k x) of { IO (ST k2) ->
  55                         k2 new_s }))
  56
  57 fixIO :: (a -> IO a) -> IO a
  58     -- not required but worth having around
  59
  60 fixIO k = IO $ ST $ \ s ->
  61     let
  62         (IO (ST k_loop)) = k loop
  63         result           = k_loop s
  64         (Right loop, _)  = result
  65     in
  66     result
  67
  68 fail            :: IOError -> IO a
  69 fail err        =  IO $ ST $ \ s -> (Left err, s)
  70
  71 userError       :: String  -> IOError
  72 userError str   =  IOError Nothing UserError str
  73
  74 catch           :: IO a    -> (IOError -> IO a) -> IO a
  75 catch (IO (ST m)) k  = IO $ ST $ \ s ->
  76   case (m s) of { (r, new_s) ->
  77   case r of
  78     Right  _ -> (r, new_s)
  79     Left err -> case (k err) of { IO (ST k_err) ->
  80                 (k_err new_s) }}
  81
  82 instance  Show (IO a)  where
  83     showsPrec p f  = showString "<<IO action>>"
  84     showList       = showList__ (showsPrec 0)
  85 \end{code}
  86
  87 %*********************************************************
  88 %*                                                      *
  89 \subsection{Coercions to @ST@ and @PrimIO@}
  90 %*                                                      *
  91 %*********************************************************
  92
  93 \begin{code}
  94 stToIO     :: ST RealWorld a -> IO a
  95 primIOToIO :: PrimIO a       -> IO a
  96 ioToST     :: IO a -> ST RealWorld a
  97 ioToPrimIO :: IO a -> PrimIO       a
  98
  99 primIOToIO = stToIO -- for backwards compatibility
 100 ioToPrimIO = ioToST
 101
 102 stToIO (ST m) = IO $ ST $ \ s ->
 103     case (m s) of { (r, new_s) ->
 104     (Right r, new_s) }
 105
 106 ioToST (IO (ST io)) = ST $ \ s ->
 107     case (io s) of { (r, new_s) ->
 108     case r of
 109       Right a -> (a, new_s)
 110       Left  e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n")
 111     }
 112 \end{code}
 113
 114 @thenIO_Prim@ is a useful little number for doing _ccall_s in IO-land:
 115
 116 \begin{code}
 117 thenIO_Prim :: PrimIO a -> (a -> IO b) -> IO b
 118 seqIO_Prim  :: PrimIO a -> IO b -> IO b
 119 {-# INLINE thenIO_Prim   #-}
 120 {-# INLINE seqIO_Prim   #-}
 121
 122 thenIO_Prim (ST m) k = IO $ ST $ \ s ->
 123     case (m s)     of { (m_res, new_s)    ->
 124     case (k m_res) of { (IO (ST k_m_res)) ->
 125     k_m_res new_s }}
 126
 127 seqIO_Prim m k = thenIO_Prim m (\ _ -> k)
 128 \end{code}
 129
 130
 131 %*********************************************************
 132 %*                                                      *
 133 \subsection{Error/trace-ish functions}
 134 %*                                                      *
 135 %*********************************************************
 136
 137 \begin{code}
 138 errorIO :: PrimIO () -> a
 139
 140 errorIO (ST io)
 141   = case (errorIO# io) of
 142       _ -> bottom
 143   where
 144     bottom = bottom -- Never evaluated
 145
 146 --errorIO x = (waitRead#, errorIO#, makeForeignObj#, waitWrite#, (+#))
 147
 148 -- error stops execution and displays an error message
 149 error :: String -> a
 150 error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s
 151
 152 error__ :: (Addr{-FILE *-} -> PrimIO ()) -> String -> a
 153
 154 error__ msg_hdr s
 155 #ifdef __PARALLEL_HASKELL__
 156   = errorIO (msg_hdr sTDERR{-msg hdr-}  >>
 157              _ccall_ fflush sTDERR      >>
 158              fputs sTDERR s             >>
 159              _ccall_ fflush sTDERR      >>
 160              _ccall_ stg_exit (1::Int)
 161             )
 162 #else
 163   = errorIO (msg_hdr sTDERR{-msg hdr-}  >>
 164              _ccall_ fflush sTDERR      >>
 165              fputs sTDERR s             >>
 166              _ccall_ fflush sTDERR      >>
 167              _ccall_ getErrorHandler    >>= \ errorHandler ->
 168              if errorHandler == (-1::Int) then
 169                 _ccall_ stg_exit (1::Int)
 170              else
 171                 _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
 172                                                 >>= \ osptr ->
 173                 _ccall_ decrementErrorCount     >>= \ () ->
 174                 deRefStablePtr osptr            >>= \ oact ->
 175                 oact
 176             )
 177 #endif {- !parallel -}
 178   where
 179     sTDERR = (``stderr'' :: Addr)
 180 \end{code}
 181
 182 \begin{code}
 183 {-# GENERATE_SPECS _trace a #-}
 184 trace :: String -> a -> a
 185
 186 trace string expr
 187   = unsafePerformPrimIO (
 188         ((_ccall_ PreTraceHook sTDERR{-msg-}):: PrimIO ())  >>
 189         fputs sTDERR string                                 >>
 190         ((_ccall_ PostTraceHook sTDERR{-msg-}):: PrimIO ()) >>
 191         returnPrimIO expr )
 192   where
 193     sTDERR = (``stderr'' :: Addr)
 194 \end{code}
 195
 196
 197 %*********************************************************
 198 %*                                                      *
 199 \subsection{Utility functions}
 200 %*                                                      *
 201 %*********************************************************
 202
 203 I'm not sure why this little function is here...
 204
 205 \begin{code}
 206 fputs :: Addr{-FILE*-} -> String -> PrimIO Bool
 207
 208 fputs stream [] = return True
 209
 210 fputs stream (c : cs)
 211   = _ccall_ stg_putc c stream >> -- stg_putc expands to putc
 212     fputs stream cs              -- (just does some casting stream)
 213 \end{code}
 214
 215
 216 %*********************************************************
 217 %*                                                      *
 218 \subsection{Type @IOError@}
 219 %*                                                      *
 220 %*********************************************************
 221
 222 A value @IOError@ encode errors occurred in the @IO@ monad.
 223 An @IOError@ records a more specific error type, a descriptive
 224 string and maybe the handle that was used when the error was
 225 flagged.
 226
 227 \begin{code}
 228 data IOError
 229  = IOError
 230      (Maybe Handle)  -- the handle used by the action flagging the
 231                      -- the error.
 232      IOErrorType     -- what it was.
 233      String          -- error type specific information.
 234
 235
 236 data IOErrorType
 237   = AlreadyExists        | HardwareFault
 238   | IllegalOperation     | InappropriateType
 239   | Interrupted          | InvalidArgument
 240   | NoSuchThing          | OtherError
 241   | PermissionDenied     | ProtocolError
 242   | ResourceBusy         | ResourceExhausted
 243   | ResourceVanished     | SystemError
 244   | TimeExpired          | UnsatisfiedConstraints
 245   | UnsupportedOperation | UserError
 246   | EOF
 247   deriving (Eq, Show)
 248
 249 \end{code}
 250
 251 Predicates on IOError; little effort made on these so far...
 252
 253 \begin{code}
 254
 255 isAlreadyExistsError (IOError _ AlreadyExists _) = True
 256 isAlreadyExistsError _                           = False
 257
 258 isAlreadyInUseError (IOError _ ResourceBusy _) = True
 259 isAlreadyInUseError _                          = False
 260
 261 isFullError (IOError _ ResourceExhausted _) = True
 262 isFullError _                               = False
 263
 264 isEOFError (IOError _ EOF _) = True
 265 isEOFError _                 = True
 266
 267 isIllegalOperation (IOError _ IllegalOperation _) = True
 268 isIllegalOperation _                              = False
 269
 270 isPermissionError (IOError _ PermissionDenied _) = True
 271 isPermissionError _                              = False
 272
 273 isDoesNotExistError (IOError _ NoSuchThing _) = True
 274 isDoesNotExistError _                         = False
 275
 276 isUserError (IOError _ UserError s) = Just s
 277 isUserError _                       = Nothing
 278 \end{code}
 279
 280 Showing @IOError@s
 281
 282 \begin{code}
 283 instance Show IOError where
 284     showsPrec p (IOError _ UserError s) rs =
 285       showString s rs
 286     showsPrec p (IOError _ EOF _) rs =
 287       showsPrec p EOF rs
 288     showsPrec p (IOError _ iot s) rs =
 289       showsPrec p
 290                 iot
 291                 (case s of {
 292                   "" -> rs;
 293                   _ -> showString ": " $
 294                        showString s rs})
 295
 296 \end{code}
 297
 298 The @String@ part of an @IOError@ is platform-dependent.  However, to
 299 provide a uniform mechanism for distinguishing among errors within
 300 these broad categories, each platform-specific standard shall specify
 301 the exact strings to be used for particular errors.  For errors not
 302 explicitly mentioned in the standard, any descriptive string may be
 303 used.
 304
 305 \begin{change}
 306 SOF & 4/96 & added argument to indicate function that flagged error
 307 \end{change}
 308 % Hmm..does these envs work?!...SOF
 309
 310 \begin{code}
 311 constructErrorAndFail :: String -> IO a
 312 constructErrorAndFail call_site
 313   = stToIO (constructError call_site) >>= \ io_error ->
 314     fail io_error
 315
 316 \end{code}
 317
 318 This doesn't seem to be documented/spelled out anywhere,
 319 so here goes: (SOF)
 320
 321 The implementation of the IO prelude uses various C stubs
 322 to do the actual interaction with the OS. The bandwidth
 323 \tr{C<->Haskell} is somewhat limited, so the general strategy
 324 for flaggging any errors (apart from possibly using the
 325 return code of the external call), is to set the @ghc_errtype@
 326 to a value that is one of the \tr{#define}s in @includes/error.h@.
 327 @ghc_errstr@ holds a character string providing error-specific
 328 information.
 329
 330 \begin{code}
 331 constructError        :: String -> PrimIO IOError
 332 constructError call_site =
 333  _casm_ ``%r = ghc_errtype;''    >>= \ (I# errtype#) ->
 334  _casm_ ``%r = ghc_errstr;''        >>= \ str ->
 335  let
 336   iot =
 337    case errtype# of
 338      ERR_ALREADYEXISTS#          -> AlreadyExists
 339      ERR_HARDWAREFAULT#          -> HardwareFault
 340      ERR_ILLEGALOPERATION#       -> IllegalOperation
 341      ERR_INAPPROPRIATETYPE#      -> InappropriateType
 342      ERR_INTERRUPTED#            -> Interrupted
 343      ERR_INVALIDARGUMENT#        -> InvalidArgument
 344      ERR_NOSUCHTHING#            -> NoSuchThing
 345      ERR_OTHERERROR#             -> OtherError
 346      ERR_PERMISSIONDENIED#       -> PermissionDenied
 347      ERR_PROTOCOLERROR#          -> ProtocolError
 348      ERR_RESOURCEBUSY#           -> ResourceBusy
 349      ERR_RESOURCEEXHAUSTED#      -> ResourceExhausted
 350      ERR_RESOURCEVANISHED#       -> ResourceVanished
 351      ERR_SYSTEMERROR#            -> SystemError
 352      ERR_TIMEEXPIRED#            -> TimeExpired
 353      ERR_UNSATISFIEDCONSTRAINTS# -> UnsatisfiedConstraints
 354      ERR_UNSUPPORTEDOPERATION#   -> UnsupportedOperation
 355      ERR_EOF#                    -> EOF
 356      _                           -> OtherError
 357
 358   msg =
 359    case iot of
 360      EOF -> ""
 361      OtherError -> "bad error construct"
 362      _   -> call_site ++ ':' : ' ' : unpackCString str
 363  in
 364  return (IOError Nothing iot msg)
 365 \end{code}
 366
 367 %*********************************************************
 368 %*                                                      *
 369 \subsection{Types @Handle@, @Handle__@}
 370 %*                                                      *
 371 %*********************************************************
 372
 373 The type for @Handle@ is defined rather than in @IOHandle@
 374 module, as the @IOError@ type uses it..all operations over
 375 a handles reside in @IOHandle@.
 376
 377 \begin{code}
 378
 379 {-
 380  Sigh, the MVar ops in ConcBase depend on IO, the IO
 381  representation here depend on MVars for handles (when
 382  compiling a concurrent way). Break the cycle by having
 383  the definition of MVars go here:
 384
 385 -}
 386 data MVar a = MVar (SynchVar# RealWorld a)
 387
 388 #if defined(__CONCURRENT_HASKELL__)
 389 type Handle = MVar Handle__
 390 #else
 391 type Handle = MutableVar RealWorld Handle__
 392 #endif
 393
 394 data Handle__
 395   = ErrorHandle         IOError
 396   | ClosedHandle
 397 #ifndef PAR
 398   | SemiClosedHandle    ForeignObj (Addr, Int)
 399   | ReadHandle          ForeignObj (Maybe BufferMode) Bool
 400   | WriteHandle         ForeignObj (Maybe BufferMode) Bool
 401   | AppendHandle        ForeignObj (Maybe BufferMode) Bool
 402   | ReadWriteHandle     ForeignObj (Maybe BufferMode) Bool
 403 #else
 404   | SemiClosedHandle    Addr (Addr, Int)
 405   | ReadHandle          Addr (Maybe BufferMode) Bool
 406   | WriteHandle         Addr (Maybe BufferMode) Bool
 407   | AppendHandle        Addr (Maybe BufferMode) Bool
 408   | ReadWriteHandle     Addr (Maybe BufferMode) Bool
 409 #endif
 410
 411 -- Standard Instances as defined by the Report..
 412 -- instance Eq Handle   (defined in IO)
 413 -- instance Show Handle    ""
 414
 415 \end{code}
 416
 417 %*********************************************************
 418 %*                                                      *
 419 \subsection[BufferMode]{Buffering modes}
 420 %*                                                      *
 421 %*********************************************************
 422
 423 Three kinds of buffering are supported: line-buffering,
 424 block-buffering or no-buffering.  These modes have the following
 425 effects. For output, items are written out from the internal
 426 buffer according to the buffer mode:
 427
 428 \begin{itemize}
 429 \item[line-buffering]  the entire output buffer is written
 430 out whenever a newline is output, the output buffer overflows,
 431 a flush is issued, or the handle is closed.
 432
 433 \item[block-buffering] the entire output buffer is written out whenever
 434 it overflows, a flush is issued, or the handle
 435 is closed.
 436
 437 \item[no-buffering] output is written immediately, and never stored
 438 in the output buffer.
 439 \end{itemize}
 440
 441 The output buffer is emptied as soon as it has been written out.
 442
 443 Similarly, input occurs according to the buffer mode for handle {\em hdl}.
 444 \begin{itemize}
 445 \item[line-buffering] when the input buffer for {\em hdl} is not empty,
 446 the next item is obtained from the buffer;
 447 otherwise, when the input buffer is empty,
 448 characters up to and including the next newline
 449 character are read into the buffer.  No characters
 450 are available until the newline character is
 451 available.
 452 \item[block-buffering] when the input buffer for {\em hdl} becomes empty,
 453 the next block of data is read into this buffer.
 454 \item[no-buffering] the next input item is read and returned.
 455 \end{itemize}
 456 For most implementations, physical files will normally be block-buffered
 457 and terminals will normally be line-buffered.
 458
 459 \begin{code}
 460 data BufferMode
 461  = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
 462    deriving (Eq, Ord, Read, Show)
 463 \end{code}