ghc/lib/std/PrelIOBase.lhs

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