ghc/lib/std/PrelIOBase.lhs

   1 % ------------------------------------------------------------------------------
   2 % $Id: PrelIOBase.lhs,v 1.26 2000/07/07 11:03:58 simonmar 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 _ (AsyncException e)         = shows e
 454   showsPrec _ (DynException _err)        = showString "unknown exception"
 455   showsPrec _ (PutFullMVar)              = showString "putMVar: full MVar"
 456   showsPrec _ (BlockedOnDeadMVar)        = showString "thread blocked indefinitely"
 457   showsPrec _ (NonTermination)           = showString "<<loop>>"
 458 \end{code}
 459
 460 %*********************************************************
 461 %*                                                      *
 462 \subsection{Primitive throw}
 463 %*                                                      *
 464 %*********************************************************
 465
 466 \begin{code}
 467 throw :: Exception -> a
 468 throw exception = raise# exception
 469
 470 ioError         :: Exception -> IO a
 471 ioError err     =  IO $ \s -> throw err s
 472
 473 ioException     :: IOException -> IO a
 474 ioException err =  IO $ \s -> throw (IOException err) s
 475 \end{code}
 476
 477 %*********************************************************
 478 %*                                                      *
 479 \subsection{Type @IOError@}
 480 %*                                                      *
 481 %*********************************************************
 482
 483 A value @IOError@ encode errors occurred in the @IO@ monad.
 484 An @IOError@ records a more specific error type, a descriptive
 485 string and maybe the handle that was used when the error was
 486 flagged.
 487
 488 \begin{code}
 489 type IOError = Exception
 490
 491 data IOException
 492  = IOError
 493      (Maybe Handle)  -- the handle used by the action flagging the
 494                      -- the error.
 495      IOErrorType     -- what it was.
 496      String          -- location
 497      String          -- error type specific information.
 498
 499 instance Eq IOException where
 500   (IOError h1 e1 loc1 str1) == (IOError h2 e2 loc2 str2) =
 501     e1==e2 && str1==str2 && h1==h2 && loc1 == loc2
 502
 503 data IOErrorType
 504   = AlreadyExists        | HardwareFault
 505   | IllegalOperation     | InappropriateType
 506   | Interrupted          | InvalidArgument
 507   | NoSuchThing          | OtherError
 508   | PermissionDenied     | ProtocolError
 509   | ResourceBusy         | ResourceExhausted
 510   | ResourceVanished     | SystemError
 511   | TimeExpired          | UnsatisfiedConstraints
 512   | UnsupportedOperation
 513   | EOF
 514 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
 515   | ComError Int           -- HRESULT
 516 #endif
 517   deriving (Eq)
 518
 519 instance Show IOErrorType where
 520   showsPrec _ e =
 521     showString $
 522     case e of
 523       AlreadyExists     -> "already exists"
 524       HardwareFault     -> "hardware fault"
 525       IllegalOperation  -> "illegal operation"
 526       InappropriateType -> "inappropriate type"
 527       Interrupted       -> "interrupted"
 528       InvalidArgument   -> "invalid argument"
 529       NoSuchThing       -> "does not exist"
 530       OtherError        -> "failed"
 531       PermissionDenied  -> "permission denied"
 532       ProtocolError     -> "protocol error"
 533       ResourceBusy      -> "resource busy"
 534       ResourceExhausted -> "resource exhausted"
 535       ResourceVanished  -> "resource vanished"
 536       SystemError       -> "system error"
 537       TimeExpired       -> "timeout"
 538       UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
 539       UnsupportedOperation -> "unsupported operation"
 540       EOF               -> "end of file"
 541 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
 542       ComError _        -> "COM error"
 543 #endif
 544
 545
 546
 547 userError       :: String  -> IOError
 548 userError str   =  UserError str
 549 \end{code}
 550
 551 Predicates on IOError; little effort made on these so far...
 552
 553 \begin{code}
 554
 555 isAlreadyExistsError :: IOError -> Bool
 556 isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _)) = True
 557 isAlreadyExistsError _                                           = False
 558
 559 isAlreadyInUseError :: IOError -> Bool
 560 isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _)) = True
 561 isAlreadyInUseError _                                          = False
 562
 563 isFullError :: IOError -> Bool
 564 isFullError (IOException (IOError _ ResourceExhausted _ _)) = True
 565 isFullError _                                               = False
 566
 567 isEOFError :: IOError -> Bool
 568 isEOFError (IOException (IOError _ EOF _ _)) = True
 569 isEOFError _                                 = False
 570
 571 isIllegalOperation :: IOError -> Bool
 572 isIllegalOperation (IOException (IOError _ IllegalOperation _ _)) = True
 573 isIllegalOperation _                                              = False
 574
 575 isPermissionError :: IOError -> Bool
 576 isPermissionError (IOException (IOError _ PermissionDenied _ _)) = True
 577 isPermissionError _                                              = False
 578
 579 isDoesNotExistError :: IOError -> Bool
 580 isDoesNotExistError (IOException (IOError _ NoSuchThing _ _)) = True
 581 isDoesNotExistError _                                         = False
 582
 583 isUserError :: IOError -> Bool
 584 isUserError (UserError _) = True
 585 isUserError _             = False
 586 \end{code}
 587
 588 Showing @IOError@s
 589
 590 \begin{code}
 591 #ifdef __HUGS__
 592 -- For now we give a fairly uninformative error message which just happens to
 593 -- be like the ones that Hugs used to give.
 594 instance Show IOException where
 595     showsPrec p (IOError hdl iot loc s) = showString s . showChar '\n'
 596 #else
 597 instance Show IOException where
 598     showsPrec p (IOError hdl iot loc s) =
 599       showsPrec p iot .
 600       showChar '\n' .
 601       (case loc of
 602          "" -> id
 603          _  -> showString "Action: " . showString loc . showChar '\n') .
 604       showHdl .
 605       (case s of
 606          "" -> id
 607          _  -> showString "Reason: " . showString s)
 608      where
 609       showHdl =
 610        case hdl of
 611         Nothing -> id
 612         Just h  -> showString "Handle: " . showsPrec p h
 613
 614 #endif
 615 \end{code}
 616
 617 The @String@ part of an @IOError@ is platform-dependent.  However, to
 618 provide a uniform mechanism for distinguishing among errors within
 619 these broad categories, each platform-specific standard shall specify
 620 the exact strings to be used for particular errors.  For errors not
 621 explicitly mentioned in the standard, any descriptive string may be
 622 used.
 623
 624 \begin{code}
 625 constructErrorAndFail :: String -> IO a
 626 constructErrorAndFail call_site
 627   = constructError call_site >>= \ io_error ->
 628     ioError (IOException io_error)
 629
 630 constructErrorAndFailWithInfo :: String -> String -> IO a
 631 constructErrorAndFailWithInfo call_site reason
 632   = constructErrorMsg call_site (Just reason) >>= \ io_error ->
 633     ioError (IOException io_error)
 634
 635 \end{code}
 636
 637 This doesn't seem to be documented/spelled out anywhere,
 638 so here goes: (SOF)
 639
 640 The implementation of the IO prelude uses various C stubs
 641 to do the actual interaction with the OS. The bandwidth
 642 \tr{C<->Haskell} is somewhat limited, so the general strategy
 643 for flaggging any errors (apart from possibly using the
 644 return code of the external call), is to set the @ghc_errtype@
 645 to a value that is one of the \tr{#define}s in @includes/error.h@.
 646 @ghc_errstr@ holds a character string providing error-specific
 647 information. Error constructing functions will then reach out
 648 and grab these values when generating
 649
 650 \begin{code}
 651 constructError        :: String -> IO IOException
 652 constructError call_site = constructErrorMsg call_site Nothing
 653
 654 constructErrorMsg             :: String -> Maybe String -> IO IOException
 655 constructErrorMsg call_site reason =
 656  getErrType__            >>= \ errtype ->
 657  getErrStr__             >>= \ str ->
 658  let
 659   iot =
 660    case (errtype::Int) of
 661      ERR_ALREADYEXISTS           -> AlreadyExists
 662      ERR_HARDWAREFAULT           -> HardwareFault
 663      ERR_ILLEGALOPERATION        -> IllegalOperation
 664      ERR_INAPPROPRIATETYPE       -> InappropriateType
 665      ERR_INTERRUPTED             -> Interrupted
 666      ERR_INVALIDARGUMENT         -> InvalidArgument
 667      ERR_NOSUCHTHING             -> NoSuchThing
 668      ERR_OTHERERROR              -> OtherError
 669      ERR_PERMISSIONDENIED        -> PermissionDenied
 670      ERR_PROTOCOLERROR           -> ProtocolError
 671      ERR_RESOURCEBUSY            -> ResourceBusy
 672      ERR_RESOURCEEXHAUSTED       -> ResourceExhausted
 673      ERR_RESOURCEVANISHED        -> ResourceVanished
 674      ERR_SYSTEMERROR             -> SystemError
 675      ERR_TIMEEXPIRED             -> TimeExpired
 676      ERR_UNSATISFIEDCONSTRAINTS -> UnsatisfiedConstraints
 677      ERR_UNSUPPORTEDOPERATION   -> UnsupportedOperation
 678      ERR_EOF                     -> EOF
 679      _                           -> OtherError
 680
 681   msg =
 682    unpackCString str ++
 683    (case iot of
 684      OtherError -> "(error code: " ++ show errtype ++ ")"
 685      _ -> "") ++
 686    (case reason of
 687       Nothing -> ""
 688       Just m  -> ' ':m)
 689  in
 690  return (IOError Nothing iot call_site msg)
 691 \end{code}