ghc/lib/std/PrelIOBase.lhs

   1 % -----------------------------------------------------------------------------
   2 % $Id: PrelIOBase.lhs,v 1.18 2000/03/14 01:52:25 sof Exp $
   3 %
   4 % (c) The AQUA Project, Glasgow University, 1994-1998
   5 %
   6
   7 \section[PrelIOBase]{Module @PrelIOBase@}
   8
   9 Definitions for the @IO@ monad and its friends.  Everything is exported
  10 concretely; the @IO@ module itself exports abstractly.
  11
  12 \begin{code}
  13 {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
  14 #include "cbits/stgerror.h"
  15 #include "config.h"
  16
  17 #ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
  18 module PrelIOBase where
  19
  20 import {-# SOURCE #-} PrelErr ( error )
  21
  22 import PrelST
  23 import PrelBase
  24 import {-# SOURCE #-} PrelException ( ioError )
  25 import PrelST     ( ST(..), STret(..) )
  26 import PrelMaybe  ( Maybe(..) )
  27 import PrelAddr   ( Addr(..), nullAddr )
  28 import PrelPack   ( unpackCString )
  29 import PrelShow
  30
  31 #if !defined(__CONCURRENT_HASKELL__)
  32 import PrelArr    ( MutableVar, readVar )
  33 #endif
  34 #endif
  35
  36 #ifdef __HUGS__
  37 #define __CONCURRENT_HASKELL__
  38 #define stToIO id
  39 #define unpackCString primUnpackString
  40 #endif
  41
  42 #ifndef __PARALLEL_HASKELL__
  43 #define FILE_OBJECT         ForeignObj
  44 #else
  45 #define FILE_OBJECT         Addr
  46 #endif
  47 \end{code}
  48
  49 %*********************************************************
  50 %*                                                      *
  51 \subsection{The @IO@ monad}
  52 %*                                                      *
  53 %*********************************************************
  54
  55 The IO Monad is just an instance of the ST monad, where the state is
  56 the real world.  We use the exception mechanism (in PrelException) to
  57 implement IO exceptions.
  58
  59 NOTE: The IO representation is deeply wired in to various parts of the
  60 system.  The following list may or may not be exhaustive:
  61
  62 Compiler  - types of various primitives in PrimOp.lhs
  63
  64 RTS       - forceIO (StgMiscClosures.hc)
  65           - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
  66             (Exceptions.hc)
  67           - raiseAsync (Schedule.c)
  68
  69 Prelude   - PrelIOBase.lhs, and several other places including
  70             PrelException.lhs.
  71
  72 Libraries - parts of hslibs/lang.
  73
  74 --SDM
  75
  76 \begin{code}
  77 #ifndef __HUGS__
  78 newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
  79
  80 unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
  81 unIO (IO a) = a
  82
  83 instance  Functor IO where
  84    fmap f x = x >>= (return . f)
  85
  86 instance  Monad IO  where
  87     {-# INLINE return #-}
  88     {-# INLINE (>>)   #-}
  89     {-# INLINE (>>=)  #-}
  90     m >> k      =  m >>= \ _ -> k
  91     return x    = IO $ \ s -> (# s, x #)
  92
  93     m >>= k     = bindIO m k
  94     fail s      = error s -- not ioError?
  95
  96 liftIO :: IO a -> State# RealWorld -> STret RealWorld a
  97 liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
  98
  99 bindIO :: IO a -> (a -> IO b) -> IO b
 100 bindIO (IO m) k = IO ( \ s ->
 101   case m s of
 102     (# new_s, a #) -> unIO (k a) new_s
 103   )
 104
 105 #endif
 106 \end{code}
 107
 108 %*********************************************************
 109 %*                                                      *
 110 \subsection{Coercions to @ST@}
 111 %*                                                      *
 112 %*********************************************************
 113
 114 \begin{code}
 115 #ifdef __HUGS__
 116 /* Hugs doesn't distinguish these types so no coercion required) */
 117 #else
 118 stToIO        :: ST RealWorld a -> IO a
 119 stToIO (ST m) = (IO m)
 120
 121 ioToST        :: IO a -> ST RealWorld a
 122 ioToST (IO m) = (ST m)
 123 #endif
 124 \end{code}
 125
 126 %*********************************************************
 127 %*                                                      *
 128 \subsection{Unsafe @IO@ operations}
 129 %*                                                      *
 130 %*********************************************************
 131
 132 \begin{code}
 133 #ifndef __HUGS__
 134 {-# NOINLINE unsafePerformIO #-}
 135 unsafePerformIO :: IO a -> a
 136 unsafePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
 137
 138 unsafeInterleaveIO :: IO a -> IO a
 139 unsafeInterleaveIO = stToIO . unsafeInterleaveST . ioToST
 140 #endif
 141 \end{code}
 142
 143 %*********************************************************
 144 %*                                                      *
 145 \subsection{Type @IOError@}
 146 %*                                                      *
 147 %*********************************************************
 148
 149 A value @IOError@ encode errors occurred in the @IO@ monad.
 150 An @IOError@ records a more specific error type, a descriptive
 151 string and maybe the handle that was used when the error was
 152 flagged.
 153
 154 \begin{code}
 155 data IOError
 156  = IOError
 157      (Maybe Handle)  -- the handle used by the action flagging the
 158                      -- the error.
 159      IOErrorType     -- what it was.
 160      String          -- location
 161      String          -- error type specific information.
 162
 163 instance Eq IOError where
 164   (IOError h1 e1 loc1 str1) == (IOError h2 e2 loc2 str2) =
 165     e1==e2 && str1==str2 && h1==h2 && loc1 == loc2
 166
 167 data IOErrorType
 168   = AlreadyExists        | HardwareFault
 169   | IllegalOperation     | InappropriateType
 170   | Interrupted          | InvalidArgument
 171   | NoSuchThing          | OtherError
 172   | PermissionDenied     | ProtocolError
 173   | ResourceBusy         | ResourceExhausted
 174   | ResourceVanished     | SystemError
 175   | TimeExpired          | UnsatisfiedConstraints
 176   | UnsupportedOperation | UserError
 177   | EOF
 178 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
 179   | ComError Int           -- HRESULT
 180 #endif
 181   deriving (Eq)
 182
 183 instance Show IOErrorType where
 184   showsPrec _ e =
 185     showString $
 186     case e of
 187       AlreadyExists     -> "already exists"
 188       HardwareFault     -> "hardware fault"
 189       IllegalOperation  -> "illegal operation"
 190       InappropriateType -> "inappropriate type"
 191       Interrupted       -> "interrupted"
 192       InvalidArgument   -> "invalid argument"
 193       NoSuchThing       -> "does not exist"
 194       OtherError        -> "failed"
 195       PermissionDenied  -> "permission denied"
 196       ProtocolError     -> "protocol error"
 197       ResourceBusy      -> "resource busy"
 198       ResourceExhausted -> "resource exhausted"
 199       ResourceVanished  -> "resource vanished"
 200       SystemError       -> "system error"
 201       TimeExpired       -> "timeout"
 202       UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
 203       UserError         -> "failed"
 204       UnsupportedOperation -> "unsupported operation"
 205       EOF               -> "end of file"
 206 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
 207       ComError _        -> "COM error"
 208 #endif
 209
 210
 211
 212 userError       :: String  -> IOError
 213 userError str   =  IOError Nothing UserError "" str
 214 \end{code}
 215
 216 Predicates on IOError; little effort made on these so far...
 217
 218 \begin{code}
 219
 220 isAlreadyExistsError :: IOError -> Bool
 221 isAlreadyExistsError (IOError _ AlreadyExists _ _) = True
 222 isAlreadyExistsError _                             = False
 223
 224 isAlreadyInUseError :: IOError -> Bool
 225 isAlreadyInUseError (IOError _ ResourceBusy _ _) = True
 226 isAlreadyInUseError _                            = False
 227
 228 isFullError :: IOError -> Bool
 229 isFullError (IOError _ ResourceExhausted _ _) = True
 230 isFullError _                                 = False
 231
 232 isEOFError :: IOError -> Bool
 233 isEOFError (IOError _ EOF _ _) = True
 234 isEOFError _                   = False
 235
 236 isIllegalOperation :: IOError -> Bool
 237 isIllegalOperation (IOError _ IllegalOperation _ _) = True
 238 isIllegalOperation _                                = False
 239
 240 isPermissionError :: IOError -> Bool
 241 isPermissionError (IOError _ PermissionDenied _ _) = True
 242 isPermissionError _                                = False
 243
 244 isDoesNotExistError :: IOError -> Bool
 245 isDoesNotExistError (IOError _ NoSuchThing _ _) = True
 246 isDoesNotExistError _                           = False
 247
 248 isUserError :: IOError -> Bool
 249 isUserError (IOError _ UserError _ _) = True
 250 isUserError _                         = False
 251 \end{code}
 252
 253 Showing @IOError@s
 254
 255 \begin{code}
 256 #ifdef __HUGS__
 257 -- For now we give a fairly uninformative error message which just happens to
 258 -- be like the ones that Hugs used to give.
 259 instance Show IOError where
 260     showsPrec p (IOError hdl iot loc s) = showString s . showChar '\n'
 261 #else
 262 instance Show IOError where
 263     showsPrec p (IOError hdl iot loc s) =
 264       showsPrec p iot .
 265       showChar '\n' .
 266       (case loc of
 267          "" -> id
 268          _  -> showString "Action: " . showString loc . showChar '\n') .
 269       showHdl .
 270       (case s of
 271          "" -> id
 272          _  -> showString "Reason: " . showString s)
 273      where
 274       showHdl =
 275        case hdl of
 276         Nothing -> id
 277         Just h  -> showString "Handle: " . showsPrec p h
 278
 279 #endif
 280 \end{code}
 281
 282 The @String@ part of an @IOError@ is platform-dependent.  However, to
 283 provide a uniform mechanism for distinguishing among errors within
 284 these broad categories, each platform-specific standard shall specify
 285 the exact strings to be used for particular errors.  For errors not
 286 explicitly mentioned in the standard, any descriptive string may be
 287 used.
 288
 289 \begin{code}
 290 constructErrorAndFail :: String -> IO a
 291 constructErrorAndFail call_site
 292   = constructError call_site >>= \ io_error ->
 293     ioError io_error
 294
 295 constructErrorAndFailWithInfo :: String -> String -> IO a
 296 constructErrorAndFailWithInfo call_site reason
 297   = constructErrorMsg call_site (Just reason) >>= \ io_error ->
 298     ioError io_error
 299
 300 \end{code}
 301
 302 This doesn't seem to be documented/spelled out anywhere,
 303 so here goes: (SOF)
 304
 305 The implementation of the IO prelude uses various C stubs
 306 to do the actual interaction with the OS. The bandwidth
 307 \tr{C<->Haskell} is somewhat limited, so the general strategy
 308 for flaggging any errors (apart from possibly using the
 309 return code of the external call), is to set the @ghc_errtype@
 310 to a value that is one of the \tr{#define}s in @includes/error.h@.
 311 @ghc_errstr@ holds a character string providing error-specific
 312 information. Error constructing functions will then reach out
 313 and grab these values when generating
 314
 315 \begin{code}
 316 constructError        :: String -> IO IOError
 317 constructError call_site = constructErrorMsg call_site Nothing
 318
 319 constructErrorMsg             :: String -> Maybe String -> IO IOError
 320 constructErrorMsg call_site reason =
 321  getErrType__            >>= \ errtype ->
 322  getErrStr__             >>= \ str ->
 323  let
 324   iot =
 325    case (errtype::Int) of
 326      ERR_ALREADYEXISTS           -> AlreadyExists
 327      ERR_HARDWAREFAULT           -> HardwareFault
 328      ERR_ILLEGALOPERATION        -> IllegalOperation
 329      ERR_INAPPROPRIATETYPE       -> InappropriateType
 330      ERR_INTERRUPTED             -> Interrupted
 331      ERR_INVALIDARGUMENT         -> InvalidArgument
 332      ERR_NOSUCHTHING             -> NoSuchThing
 333      ERR_OTHERERROR              -> OtherError
 334      ERR_PERMISSIONDENIED        -> PermissionDenied
 335      ERR_PROTOCOLERROR           -> ProtocolError
 336      ERR_RESOURCEBUSY            -> ResourceBusy
 337      ERR_RESOURCEEXHAUSTED       -> ResourceExhausted
 338      ERR_RESOURCEVANISHED        -> ResourceVanished
 339      ERR_SYSTEMERROR             -> SystemError
 340      ERR_TIMEEXPIRED             -> TimeExpired
 341      ERR_UNSATISFIEDCONSTRAINTS -> UnsatisfiedConstraints
 342      ERR_UNSUPPORTEDOPERATION   -> UnsupportedOperation
 343      ERR_EOF                     -> EOF
 344      _                           -> OtherError
 345
 346   msg =
 347    unpackCString str ++
 348    (case iot of
 349      OtherError -> "(error code: " ++ show errtype ++ ")"
 350      _ -> "") ++
 351    (case reason of
 352       Nothing -> ""
 353       Just m  -> ' ':m)
 354  in
 355  return (IOError Nothing iot call_site msg)
 356 \end{code}
 357
 358 File names are specified using @FilePath@, a OS-dependent
 359 string that (hopefully, I guess) maps to an accessible file/object.
 360
 361 \begin{code}
 362 type FilePath = String
 363 \end{code}
 364
 365 %*********************************************************
 366 %*                                                      *
 367 \subsection{Types @Handle@, @Handle__@}
 368 %*                                                      *
 369 %*********************************************************
 370
 371 The type for @Handle@ is defined rather than in @IOHandle@
 372 module, as the @IOError@ type uses it..all operations over
 373 a handles reside in @IOHandle@.
 374
 375 \begin{code}
 376
 377 #ifndef __HUGS__
 378 {-
 379  Sigh, the MVar ops in ConcBase depend on IO, the IO
 380  representation here depend on MVars for handles (when
 381  compiling in a concurrent way). Break the cycle by having
 382  the definition of MVars go here:
 383
 384 -}
 385 data MVar a = MVar (MVar# RealWorld a)
 386
 387 -- pull in Eq (Mvar a) too, to avoid PrelConc being an orphan-instance module
 388 instance Eq (MVar a) where
 389         (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
 390
 391 {-
 392   Double sigh - ForeignObj is needed here too to break a cycle.
 393 -}
 394 data ForeignObj = ForeignObj ForeignObj#   -- another one
 395 instance CCallable ForeignObj
 396
 397 eqForeignObj :: ForeignObj  -> ForeignObj -> Bool
 398 eqForeignObj mp1 mp2
 399   = unsafePerformIO (primEqForeignObj mp1 mp2) /= (0::Int)
 400
 401 foreign import "eqForeignObj" unsafe primEqForeignObj :: ForeignObj -> ForeignObj -> IO Int
 402
 403 instance Eq ForeignObj where
 404     p == q = eqForeignObj p q
 405     p /= q = not (eqForeignObj p q)
 406 #endif /* ndef __HUGS__ */
 407
 408 #if defined(__CONCURRENT_HASKELL__)
 409 newtype Handle = Handle (MVar Handle__)
 410 #else
 411 newtype Handle = Handle (MutableVar RealWorld Handle__)
 412 #endif
 413
 414 instance Eq Handle where
 415  (Handle h1) == (Handle h2) = h1 == h2
 416
 417 {-
 418   A Handle is represented by (a reference to) a record
 419   containing the state of the I/O port/device. We record
 420   the following pieces of info:
 421
 422     * type (read,write,closed etc.)
 423     * pointer to the external file object.
 424     * buffering mode
 425     * user-friendly name (usually the
 426       FilePath used when IO.openFile was called)
 427
 428 Note: when a Handle is garbage collected, we want to flush its buffer
 429 and close the OS file handle, so as to free up a (precious) resource.
 430 -}
 431 data Handle__
 432   = Handle__ {
 433       haFO__          :: FILE_OBJECT,
 434       haType__        :: Handle__Type,
 435       haBufferMode__  :: BufferMode,
 436       haFilePath__    :: FilePath
 437     }
 438
 439 {-
 440   Internally, we classify handles as being one
 441   of the following:
 442 -}
 443 data Handle__Type
 444  = ErrorHandle  IOError
 445  | ClosedHandle
 446  | SemiClosedHandle
 447  | ReadHandle
 448  | WriteHandle
 449  | AppendHandle
 450  | ReadWriteHandle
 451
 452
 453 -- handle types are 'show'ed when printing error msgs, so
 454 -- we provide a more user-friendly Show instance for it
 455 -- than the derived one.
 456 instance Show Handle__Type where
 457   showsPrec p t =
 458     case t of
 459       ErrorHandle iot   -> showString "error " . showsPrec p iot
 460       ClosedHandle      -> showString "closed"
 461       SemiClosedHandle  -> showString "semi-closed"
 462       ReadHandle        -> showString "readable"
 463       WriteHandle       -> showString "writeable"
 464       AppendHandle      -> showString "writeable (append)"
 465       ReadWriteHandle   -> showString "read-writeable"
 466
 467 instance Show Handle where
 468   showsPrec p (Handle h) =
 469     let
 470 #if defined(__CONCURRENT_HASKELL__)
 471 #ifdef __HUGS__
 472      hdl_ = unsafePerformIO (primTakeMVar h)
 473 #else
 474      -- (Big) SIGH: unfolded defn of takeMVar to avoid
 475      -- an (oh-so) unfortunate module loop with PrelConc.
 476      hdl_ = unsafePerformIO (IO $ \ s# ->
 477              case h               of { MVar h# ->
 478              case takeMVar# h# s# of { (# s2# , r #) ->
 479                     (# s2#, r #) }})
 480 #endif
 481 #else
 482      hdl_ = unsafePerformIO (stToIO (readVar h))
 483 #endif
 484     in
 485     showChar '{' .
 486     showHdl (haType__ hdl_)
 487             (showString "loc=" . showString (haFilePath__ hdl_) . showChar ',' .
 488              showString "type=" . showsPrec p (haType__ hdl_) . showChar ',' .
 489              showString "buffering=" . showBufMode (haFO__ hdl_) (haBufferMode__ hdl_) . showString "}\n" )
 490    where
 491     showHdl :: Handle__Type -> ShowS -> ShowS
 492     showHdl ht cont =
 493        case ht of
 494         ClosedHandle  -> showsPrec p ht . showString "}\n"
 495         ErrorHandle _ -> showsPrec p ht . showString "}\n"
 496         _ -> cont
 497
 498     showBufMode :: FILE_OBJECT -> BufferMode -> ShowS
 499     showBufMode fo bmo =
 500       case bmo of
 501         NoBuffering   -> showString "none"
 502         LineBuffering -> showString "line"
 503         BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n)
 504         BlockBuffering Nothing  -> showString "block " . showParen True (showsPrec p def)
 505       where
 506        def :: Int
 507        def = unsafePerformIO (getBufSize fo)
 508
 509 mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
 510 mkBuffer__ fo sz_in_bytes = do
 511  chunk <-
 512   case sz_in_bytes of
 513     0 -> return nullAddr  -- this has the effect of overwriting the pointer to the old buffer.
 514     _ -> do
 515      chunk <- allocMemory__ sz_in_bytes
 516      if chunk == nullAddr
 517       then ioError (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
 518       else return chunk
 519  setBuf fo chunk sz_in_bytes
 520
 521 \end{code}
 522
 523 %*********************************************************
 524 %*                                                      *
 525 \subsection[BufferMode]{Buffering modes}
 526 %*                                                      *
 527 %*********************************************************
 528
 529 Three kinds of buffering are supported: line-buffering,
 530 block-buffering or no-buffering.  These modes have the following
 531 effects. For output, items are written out from the internal
 532 buffer according to the buffer mode:
 533
 534 \begin{itemize}
 535 \item[line-buffering]  the entire output buffer is written
 536 out whenever a newline is output, the output buffer overflows,
 537 a flush is issued, or the handle is closed.
 538
 539 \item[block-buffering] the entire output buffer is written out whenever
 540 it overflows, a flush is issued, or the handle
 541 is closed.
 542
 543 \item[no-buffering] output is written immediately, and never stored
 544 in the output buffer.
 545 \end{itemize}
 546
 547 The output buffer is emptied as soon as it has been written out.
 548
 549 Similarly, input occurs according to the buffer mode for handle {\em hdl}.
 550 \begin{itemize}
 551 \item[line-buffering] when the input buffer for {\em hdl} is not empty,
 552 the next item is obtained from the buffer;
 553 otherwise, when the input buffer is empty,
 554 characters up to and including the next newline
 555 character are read into the buffer.  No characters
 556 are available until the newline character is
 557 available.
 558 \item[block-buffering] when the input buffer for {\em hdl} becomes empty,
 559 the next block of data is read into this buffer.
 560 \item[no-buffering] the next input item is read and returned.
 561 \end{itemize}
 562
 563 For most implementations, physical files will normally be block-buffered
 564 and terminals will normally be line-buffered. (the IO interface provides
 565 operations for changing the default buffering of a handle tho.)
 566
 567 \begin{code}
 568 data BufferMode
 569  = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
 570    deriving (Eq, Ord, Show)
 571    {- Read instance defined in IO. -}
 572
 573 \end{code}
 574
 575 Foreign import declarations to helper routines:
 576
 577 \begin{code}
 578 foreign import "libHS_cbits" "getErrStr__"  unsafe getErrStr__  :: IO Addr
 579 foreign import "libHS_cbits" "getErrNo__"   unsafe getErrNo__   :: IO Int
 580 foreign import "libHS_cbits" "getErrType__" unsafe getErrType__ :: IO Int
 581
 582 foreign import "libHS_cbits" "allocMemory__" unsafe
 583            allocMemory__    :: Int -> IO Addr
 584 foreign import "libHS_cbits" "getBufSize"  unsafe
 585            getBufSize       :: FILE_OBJECT -> IO Int
 586 foreign import "libHS_cbits" "setBuf" unsafe
 587            setBuf       :: FILE_OBJECT -> Addr -> Int -> IO ()
 588
 589 \end{code}