ghc/lib/std/PrelIOBase.lhs

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