ghc/lib/std/PrelIOBase.lhs

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