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