ghc/lib/std/PrelIOBase.lhs

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