ghc/lib/std/PrelIOBase.lhs

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