ghc/lib/std/PrelIOBase.lhs

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