[project @ 2002-02-12 11:44:54 by simonmar]

[ghc-hetmet.git] / ghc / lib / std / PrelIOBase.lhs

diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs
index 2e43613..51a16dc 100644 (file)
--- a/ghc/lib/std/PrelIOBase.lhs
+++ b/ghc/lib/std/PrelIOBase.lhs
@@ -1,67 +1,52 @@
-% -----------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.12 1999/08/23 12:53:25 keithw Exp $
+% ------------------------------------------------------------------------------
+% $Id: PrelIOBase.lhs,v 1.47 2002/01/29 17:12:53 simonmar Exp $

 % 
 % 

-% (c) The AQUA Project, Glasgow University, 1994-1998
+% (c) The University of Glasgow, 1994-2001

 %
 
 %
 

-\section[PrelIOBase]{Module @PrelIOBase@}
-
-Definitions for the @IO@ monad and its friends.  Everything is exported
-concretely; the @IO@ module itself exports abstractly.
+% Definitions for the @IO@ monad and its friends.  Everything is exported
+% concretely; the @IO@ module itself exports abstractly.

 
 \begin{code}
 
 \begin{code}

-{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
-#include "cbits/error.h"
-
-#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
+{-# OPTIONS -fno-implicit-prelude #-}

 module PrelIOBase where
 
 module PrelIOBase where
 

-import {-# SOURCE #-} PrelErr ( error )
-

 import PrelST
 import PrelST

+import PrelArr

 import PrelBase
 import PrelBase

-import {-# SOURCE #-} PrelException ( ioError )
-import PrelST    ( ST(..), STret(..) )
+import PrelNum -- To get fromInteger etc, needed because of -fno-implicit-prelude

 import PrelMaybe  ( Maybe(..) )
 import PrelMaybe  ( Maybe(..) )

-import PrelAddr          ( Addr(..), nullAddr )
-import PrelPack   ( unpackCString )

 import PrelShow
 import PrelShow

+import PrelList
+import PrelRead
+import PrelDynamic

 
 

-#if !defined(__CONCURRENT_HASKELL__)
-import PrelArr   ( MutableVar, readVar )
-#endif
-#endif
-
-#ifdef __HUGS__
-#define cat2(x,y)  x/**/y
-#define CCALL(fun) cat2(prim_,fun)
-#define __CONCURRENT_HASKELL__
-#define stToIO id
-#define unpackCString primUnpackString
-#else
-#define CCALL(fun) _ccall_ fun
-#define ref_freeStdFileObject (``&freeStdFileObject''::Addr)
-#endif
-
-#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT        ForeignObj
-#else
-#define FILE_OBJECT        Addr
-#endif
-\end{code}
-
-%*********************************************************
-%*                                                     *
-\subsection{The @IO@ monad}
-%*                                                     *
-%*********************************************************
+-- ---------------------------------------------------------------------------
+-- The IO Monad

 
 

+{-

 The IO Monad is just an instance of the ST monad, where the state is
 the real world.  We use the exception mechanism (in PrelException) to
 implement IO exceptions.
 
 The IO Monad is just an instance of the ST monad, where the state is
 the real world.  We use the exception mechanism (in PrelException) to
 implement IO exceptions.
 

-\begin{code}
-#ifndef __HUGS__
+NOTE: The IO representation is deeply wired in to various parts of the
+system.  The following list may or may not be exhaustive:
+
+Compiler  - types of various primitives in PrimOp.lhs
+
+RTS      - forceIO (StgMiscClosures.hc)
+         - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast 
+           (Exceptions.hc)
+         - raiseAsync (Schedule.c)
+
+Prelude   - PrelIOBase.lhs, and several other places including
+           PrelException.lhs.
+
+Libraries - parts of hslibs/lang.
+
+--SDM
+-}
+

 newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
 
 unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
 newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
 
 unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))

@@ -75,14 +60,13 @@ instance  Monad IO  where
     {-# INLINE (>>)   #-}
     {-# INLINE (>>=)  #-}
     m >> k      =  m >>= \ _ -> k
     {-# INLINE (>>)   #-}
     {-# INLINE (>>=)  #-}
     m >> k      =  m >>= \ _ -> k

-    return x   = IO $ \ s -> (# s, x #)
+    return x   = returnIO x

 
     m >>= k     = bindIO m k
 
     m >>= k     = bindIO m k

-    fail s     = error s -- not ioError?
+    fail s     = failIO s

 
 

-    -- not required but worth having around
-fixIO          :: (a -> IO a) -> IO a
-fixIO m         = stToIO (fixST (ioToST . m))
+failIO :: String -> IO a
+failIO s = ioError (userError s)

 
 liftIO :: IO a -> State# RealWorld -> STret RealWorld a
 liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
 
 liftIO :: IO a -> State# RealWorld -> STret RealWorld a
 liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r

@@ -93,64 +77,459 @@ bindIO (IO m) k = IO ( \ s ->
     (# new_s, a #) -> unIO (k a) new_s
   )
 
     (# new_s, a #) -> unIO (k a) new_s
   )
 

-#endif
-\end{code}
+returnIO :: a -> IO a
+returnIO x = IO (\ s -> (# s, x #))

 
 

-%*********************************************************
-%*                                                     *
-\subsection{Coercions to @ST@}
-%*                                                     *
-%*********************************************************
+-- ---------------------------------------------------------------------------
+-- Coercions between IO and ST

 
 

-\begin{code}
-#ifdef __HUGS__
-/* Hugs doesn't distinguish these types so no coercion required) */
-#else
+--stToIO        :: (forall s. ST s a) -> IO a

 stToIO       :: ST RealWorld a -> IO a
 stToIO       :: ST RealWorld a -> IO a

-stToIO (ST m) = (IO m)
+stToIO (ST m) = IO m

 
 ioToST       :: IO a -> ST RealWorld a
 ioToST (IO m) = (ST m)
 
 ioToST       :: IO a -> ST RealWorld a
 ioToST (IO m) = (ST m)

-#endif
-\end{code}

 
 

-%*********************************************************
-%*                                                     *
-\subsection{Unsafe @IO@ operations}
-%*                                                     *
-%*********************************************************
+-- ---------------------------------------------------------------------------
+-- Unsafe IO operations

 
 

-\begin{code}
-#ifndef __HUGS__

 {-# NOINLINE unsafePerformIO #-}
 unsafePerformIO        :: IO a -> a
 unsafePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
 
 {-# NOINLINE unsafePerformIO #-}
 unsafePerformIO        :: IO a -> a
 unsafePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
 

+{-# NOINLINE unsafeInterleaveIO #-}

 unsafeInterleaveIO :: IO a -> IO a
 unsafeInterleaveIO :: IO a -> IO a

-unsafeInterleaveIO = stToIO . unsafeInterleaveST . ioToST
-#endif
-\end{code}
+unsafeInterleaveIO (IO m)
+  = IO ( \ s -> let
+                  r = case m s of (# _, res #) -> res
+               in
+               (# s, r #))

 
 

-%*********************************************************
-%*                                                     *
-\subsection{Type @IOError@}
-%*                                                     *
-%*********************************************************
+-- ---------------------------------------------------------------------------
+-- Handle type

 
 

-A value @IOError@ encode errors occurred in the @IO@ monad.
-An @IOError@ records a more specific error type, a descriptive
-string and maybe the handle that was used when the error was
-flagged.
+data MVar a = MVar (MVar# RealWorld a)

 
 

-\begin{code}
-data IOError 
- = IOError 
-     (Maybe Handle)  -- the handle used by the action flagging the
-                    -- the error.
-     IOErrorType     -- what it was.
-     String         -- location
-     String          -- error type specific information.
+-- pull in Eq (Mvar a) too, to avoid PrelConc being an orphan-instance module
+instance Eq (MVar a) where
+       (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
+
+--  A Handle is represented by (a reference to) a record 
+--  containing the state of the I/O port/device. We record
+--  the following pieces of info:
+
+--    * type (read,write,closed etc.)
+--    * the underlying file descriptor
+--    * buffering mode 
+--    * buffer, and spare buffers
+--    * user-friendly name (usually the
+--     FilePath used when IO.openFile was called)
+
+-- Note: when a Handle is garbage collected, we want to flush its buffer
+-- and close the OS file handle, so as to free up a (precious) resource.
+
+data Handle 
+  = FileHandle                         -- A normal handle to a file
+       !(MVar Handle__)
+
+  | DuplexHandle                       -- A handle to a read/write stream
+       !(MVar Handle__)                -- The read side
+       !(MVar Handle__)                -- The write side
+
+-- NOTES:
+--    * A 'FileHandle' is seekable.  A 'DuplexHandle' may or may not be
+--      seekable.
+
+instance Eq Handle where
+ (FileHandle h1)     == (FileHandle h2)     = h1 == h2
+ (DuplexHandle h1 _) == (DuplexHandle h2 _) = h1 == h2
+ _ == _ = False 
+
+type FD = Int -- XXX ToDo: should be CInt
+
+data Handle__
+  = Handle__ {
+      haFD         :: !FD,                  -- file descriptor
+      haType        :: HandleType,          -- type (read/write/append etc.)
+      haIsBin       :: Bool,                -- binary mode?
+      haIsStream    :: Bool,                -- is this a stream handle?
+      haBufferMode  :: BufferMode,          -- buffer contains read/write data?
+      haFilePath    :: FilePath,            -- file name, possibly
+      haBuffer     :: !(IORef Buffer),      -- the current buffer
+      haBuffers     :: !(IORef BufferList),  -- spare buffers
+      haOtherSide   :: Maybe (MVar Handle__) -- ptr to the write side of a 
+                                            -- duplex handle.
+    }
+
+-- ---------------------------------------------------------------------------
+-- Buffers
+
+-- The buffer is represented by a mutable variable containing a
+-- record, where the record contains the raw buffer and the start/end
+-- points of the filled portion.  We use a mutable variable so that
+-- the common operation of writing (or reading) some data from (to)
+-- the buffer doesn't need to modify, and hence copy, the handle
+-- itself, it just updates the buffer.  
+
+-- There will be some allocation involved in a simple hPutChar in
+-- order to create the new Buffer structure (below), but this is
+-- relatively small, and this only has to be done once per write
+-- operation.
+
+-- The buffer contains its size - we could also get the size by
+-- calling sizeOfMutableByteArray# on the raw buffer, but that tends
+-- to be rounded up to the nearest Word.
+
+type RawBuffer = MutableByteArray# RealWorld
+
+-- INVARIANTS on a Buffer:
+--
+--   * A handle *always* has a buffer, even if it is only 1 character long
+--     (an unbuffered handle needs a 1 character buffer in order to support
+--      hLookAhead and hIsEOF).
+--   * r <= w
+--   * if r == w, then r == 0 && w == 0
+--   * if state == WriteBuffer, then r == 0
+--   * a write buffer is never full.  If an operation
+--     fills up the buffer, it will always flush it before 
+--     returning.
+--   * a read buffer may be full as a result of hLookAhead.  In normal
+--     operation, a read buffer always has at least one character of space.
+
+data Buffer 
+  = Buffer {
+       bufBuf   :: RawBuffer,
+       bufRPtr  :: !Int,
+       bufWPtr  :: !Int,
+       bufSize  :: !Int,
+       bufState :: BufferState
+  }
+
+data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
+
+-- we keep a few spare buffers around in a handle to avoid allocating
+-- a new one for each hPutStr.  These buffers are *guaranteed* to be the
+-- same size as the main buffer.
+data BufferList 
+  = BufferListNil 
+  | BufferListCons RawBuffer BufferList
+
+
+bufferIsWritable :: Buffer -> Bool
+bufferIsWritable Buffer{ bufState=WriteBuffer } = True
+bufferIsWritable _other = False
+
+bufferEmpty :: Buffer -> Bool
+bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w
+
+-- only makes sense for a write buffer
+bufferFull :: Buffer -> Bool
+bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b
+
+--  Internally, we classify handles as being one
+--  of the following:
+
+data HandleType
+ = ClosedHandle
+ | SemiClosedHandle
+ | ReadHandle
+ | WriteHandle
+ | AppendHandle
+ | ReadWriteHandle
+
+isReadableHandleType ReadHandle         = True
+isReadableHandleType ReadWriteHandle    = True
+isReadableHandleType _                 = False
+
+isWritableHandleType AppendHandle    = True
+isWritableHandleType WriteHandle     = True
+isWritableHandleType ReadWriteHandle = True
+isWritableHandleType _              = False
+
+-- File names are specified using @FilePath@, a OS-dependent
+-- string that (hopefully, I guess) maps to an accessible file/object.
+
+type FilePath = String
+
+-- ---------------------------------------------------------------------------
+-- Buffering modes
+
+-- Three kinds of buffering are supported: line-buffering, 
+-- block-buffering or no-buffering.  These modes have the following
+-- effects. For output, items are written out from the internal
+-- buffer according to the buffer mode:
+--
+-- * line-buffering  the entire output buffer is written
+--   out whenever a newline is output, the output buffer overflows, 
+--   a flush is issued, or the handle is closed.
+--
+-- * block-buffering the entire output buffer is written out whenever 
+--   it overflows, a flush is issued, or the handle
+--   is closed.
+--
+-- * no-buffering output is written immediately, and never stored
+--   in the output buffer.
+--
+-- The output buffer is emptied as soon as it has been written out.
+
+-- Similarly, input occurs according to the buffer mode for handle {\em hdl}.
+
+-- * line-buffering when the input buffer for the handle is not empty,
+--   the next item is obtained from the buffer;
+--   otherwise, when the input buffer is empty,
+--   characters up to and including the next newline
+--   character are read into the buffer.  No characters
+--   are available until the newline character is
+--   available.
+--
+-- * block-buffering when the input buffer for the handle becomes empty,
+--   the next block of data is read into this buffer.
+--
+-- * no-buffering the next input item is read and returned.
+
+-- For most implementations, physical files will normally be block-buffered 
+-- and terminals will normally be line-buffered. (the IO interface provides
+-- operations for changing the default buffering of a handle tho.)
+
+data BufferMode  
+ = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
+   deriving (Eq, Ord, Read, Show)
+
+-- ---------------------------------------------------------------------------
+-- IORefs
+
+newtype IORef a = IORef (STRef RealWorld a) deriving Eq
+
+newIORef    :: a -> IO (IORef a)
+newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)
+
+readIORef   :: IORef a -> IO a
+readIORef  (IORef var) = stToIO (readSTRef var)
+
+writeIORef  :: IORef a -> a -> IO ()
+writeIORef (IORef var) v = stToIO (writeSTRef var v)
+
+modifyIORef :: IORef a -> (a -> a) -> IO ()
+modifyIORef ref f = readIORef ref >>= \x -> writeIORef ref (f x)
+
+-- deprecated, use modifyIORef
+updateIORef :: IORef a -> (a -> a) -> IO ()
+updateIORef = modifyIORef
+
+-- ---------------------------------------------------------------------------
+-- Show instance for Handles
+
+-- handle types are 'show'n when printing error msgs, so
+-- we provide a more user-friendly Show instance for it
+-- than the derived one.
+
+instance Show HandleType where
+  showsPrec p t =
+    case t of
+      ClosedHandle      -> showString "closed"
+      SemiClosedHandle  -> showString "semi-closed"
+      ReadHandle        -> showString "readable"
+      WriteHandle       -> showString "writable"
+      AppendHandle      -> showString "writable (append)"
+      ReadWriteHandle   -> showString "read-writable"
+
+instance Show Handle where 
+  showsPrec p (FileHandle   h)   = showHandle p h False
+  showsPrec p (DuplexHandle _ h) = showHandle p h True
+   
+showHandle p h duplex =
+    let
+     -- (Big) SIGH: unfolded defn of takeMVar to avoid
+     -- an (oh-so) unfortunate module loop with PrelConc.
+     hdl_ = unsafePerformIO (IO $ \ s# ->
+            case h                 of { MVar h# ->
+            case takeMVar# h# s#   of { (# s2# , r #) -> 
+            case putMVar# h# r s2# of { s3# ->
+            (# s3#, r #) }}})

 
 

+     showType | duplex = showString "duplex (read-write)"
+             | otherwise = showsPrec p (haType hdl_)
+    in
+    showChar '{' . 
+    showHdl (haType hdl_) 
+           (showString "loc=" . showString (haFilePath hdl_) . showChar ',' .
+            showString "type=" . showType . showChar ',' .
+            showString "binary=" . showsPrec p (haIsBin hdl_) . showChar ',' .
+            showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
+   where
+
+    showHdl :: HandleType -> ShowS -> ShowS
+    showHdl ht cont = 
+       case ht of
+        ClosedHandle  -> showsPrec p ht . showString "}"
+       _ -> cont
+       
+    showBufMode :: Buffer -> BufferMode -> ShowS
+    showBufMode buf bmo =
+      case bmo of
+        NoBuffering   -> showString "none"
+       LineBuffering -> showString "line"
+       BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n)
+       BlockBuffering Nothing  -> showString "block " . showParen True (showsPrec p def)
+      where
+       def :: Int 
+       def = bufSize buf
+
+-- ------------------------------------------------------------------------
+-- Exception datatype and operations
+
+data Exception
+  = IOException        IOException     -- IO exceptions
+  | ArithException     ArithException  -- Arithmetic exceptions
+  | ArrayException     ArrayException  -- Array-related exceptions
+  | ErrorCall          String          -- Calls to 'error'
+  | ExitException      ExitCode        -- Call to System.exitWith
+  | NoMethodError       String         -- A non-existent method was invoked
+  | PatternMatchFail   String          -- A pattern match / guard failure
+  | RecSelError                String          -- Selecting a non-existent field
+  | RecConError                String          -- Field missing in record construction
+  | RecUpdError                String          -- Record doesn't contain updated field
+  | AssertionFailed    String          -- Assertions
+  | DynException       Dynamic         -- Dynamic exceptions
+  | AsyncException     AsyncException  -- Externally generated errors
+  | BlockedOnDeadMVar                  -- Blocking on a dead MVar
+  | NonTermination                     -- Cyclic data dependency or other loop
+  | Deadlock                           -- no threads can run (raised in main thread)
+  | UserError          String
+
+data ArithException
+  = Overflow
+  | Underflow
+  | LossOfPrecision
+  | DivideByZero
+  | Denormal
+  deriving (Eq, Ord)
+
+data AsyncException
+  = StackOverflow
+  | HeapOverflow
+  | ThreadKilled
+  deriving (Eq, Ord)
+
+data ArrayException
+  = IndexOutOfBounds   String          -- out-of-range array access
+  | UndefinedElement   String          -- evaluating an undefined element
+  deriving (Eq, Ord)
+
+stackOverflow, heapOverflow :: Exception -- for the RTS
+stackOverflow = AsyncException StackOverflow
+heapOverflow  = AsyncException HeapOverflow
+
+instance Show ArithException where
+  showsPrec _ Overflow        = showString "arithmetic overflow"
+  showsPrec _ Underflow       = showString "arithmetic underflow"
+  showsPrec _ LossOfPrecision = showString "loss of precision"
+  showsPrec _ DivideByZero    = showString "divide by zero"
+  showsPrec _ Denormal        = showString "denormal"
+
+instance Show AsyncException where
+  showsPrec _ StackOverflow   = showString "stack overflow"
+  showsPrec _ HeapOverflow    = showString "heap overflow"
+  showsPrec _ ThreadKilled    = showString "thread killed"
+
+instance Show ArrayException where
+  showsPrec _ (IndexOutOfBounds s)
+       = showString "array index out of range"
+       . (if not (null s) then showString ": " . showString s
+                          else id)
+  showsPrec _ (UndefinedElement s)
+       = showString "undefined array element"
+       . (if not (null s) then showString ": " . showString s
+                          else id)
+
+instance Show Exception where
+  showsPrec _ (IOException err)                 = shows err
+  showsPrec _ (ArithException err)       = shows err
+  showsPrec _ (ArrayException err)       = shows err
+  showsPrec _ (ErrorCall err)           = showString err
+  showsPrec _ (ExitException err)        = showString "exit: " . shows err
+  showsPrec _ (NoMethodError err)        = showString err
+  showsPrec _ (PatternMatchFail err)     = showString err
+  showsPrec _ (RecSelError err)                 = showString err
+  showsPrec _ (RecConError err)                 = showString err
+  showsPrec _ (RecUpdError err)                 = showString err
+  showsPrec _ (AssertionFailed err)      = showString err
+  showsPrec _ (DynException _err)        = showString "unknown exception"
+  showsPrec _ (AsyncException e)        = shows e
+  showsPrec _ (BlockedOnDeadMVar)       = showString "thread blocked indefinitely"
+  showsPrec _ (NonTermination)           = showString "<<loop>>"
+  showsPrec _ (Deadlock)                 = showString "<<deadlock>>"
+  showsPrec _ (UserError err)            = showString err
+
+instance Eq Exception where
+  IOException e1      == IOException e2      = e1 == e2
+  ArithException e1   == ArithException e2   = e1 == e2
+  ArrayException e1   == ArrayException e2   = e1 == e2
+  ErrorCall e1        == ErrorCall e2       = e1 == e2
+  ExitException        e1    == ExitException e2    = e1 == e2
+  NoMethodError e1    == NoMethodError e2    = e1 == e2
+  PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2
+  RecSelError e1      == RecSelError e2      = e1 == e2
+  RecConError e1      == RecConError e2      = e1 == e2
+  RecUpdError e1      == RecUpdError e2      = e1 == e2
+  AssertionFailed e1  == AssertionFailed e2  = e1 == e2
+  DynException _      == DynException _      = False -- incomparable
+  AsyncException e1   == AsyncException e2   = e1 == e2
+  BlockedOnDeadMVar   == BlockedOnDeadMVar   = True
+  NonTermination      == NonTermination      = True
+  Deadlock            == Deadlock            = True
+  UserError e1        == UserError e2        = e1 == e2
+
+-- -----------------------------------------------------------------------------
+-- The ExitCode type
+
+-- The `ExitCode' type defines the exit codes that a program
+-- can return.  `ExitSuccess' indicates successful termination;
+-- and `ExitFailure code' indicates program failure
+-- with value `code'.  The exact interpretation of `code'
+-- is operating-system dependent.  In particular, some values of 
+-- `code' may be prohibited (e.g. 0 on a POSIX-compliant system).
+
+-- We need it here because it is used in ExitException in the
+-- Exception datatype (above).
+
+data ExitCode = ExitSuccess | ExitFailure Int 
+                deriving (Eq, Ord, Read, Show)
+
+-- --------------------------------------------------------------------------
+-- Primitive throw
+
+throw :: Exception -> a
+throw exception = raise# exception
+
+ioError         :: Exception -> IO a 
+ioError err    =  IO $ \s -> throw err s
+
+ioException    :: IOException -> IO a
+ioException err =  IO $ \s -> throw (IOException err) s
+
+-- ---------------------------------------------------------------------------
+-- IOError type
+
+-- A value @IOError@ encode errors occurred in the @IO@ monad.
+-- An @IOError@ records a more specific error type, a descriptive
+-- string and maybe the handle that was used when the error was
+-- flagged.
+
+type IOError = Exception
+
+data IOException
+ = IOError
+     (Maybe Handle)   -- the handle used by the action flagging the
+                     --   the error.
+     IOErrorType      -- what it was.
+     String          -- location.
+     String           -- error type specific information.
+     (Maybe FilePath) -- filename the error is related to.
+
+instance Eq IOException where
+  (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = 
+    e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2

 
 data IOErrorType
   = AlreadyExists        | HardwareFault
 
 data IOErrorType
   = AlreadyExists        | HardwareFault

@@ -161,12 +540,15 @@ data IOErrorType
   | ResourceBusy         | ResourceExhausted
   | ResourceVanished     | SystemError
   | TimeExpired          | UnsatisfiedConstraints
   | ResourceBusy         | ResourceExhausted
   | ResourceVanished     | SystemError
   | TimeExpired          | UnsatisfiedConstraints

-  | UnsupportedOperation | UserError
+  | UnsupportedOperation

   | EOF
   | EOF

-#ifdef _WIN32
-  | ComError Int           -- HRESULT
-#endif
-  deriving (Eq)
+  | DynIOError Dynamic -- cheap&cheerful extensible IO error type.
+
+instance Eq IOErrorType where
+   x == y = 
+     case x of
+       DynIOError{} -> False -- from a strictness POV, compatible with a derived Eq inst?
+       _ -> getTag# x ==# getTag# y

 
 instance Show IOErrorType where
   showsPrec _ e =
 
 instance Show IOErrorType where
   showsPrec _ e =

@@ -188,358 +570,64 @@ instance Show IOErrorType where
       SystemError      -> "system error"
       TimeExpired       -> "timeout"
       UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
       SystemError      -> "system error"
       TimeExpired       -> "timeout"
       UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!

-      UserError         -> "failed"

       UnsupportedOperation -> "unsupported operation"
       EOF              -> "end of file"
       UnsupportedOperation -> "unsupported operation"
       EOF              -> "end of file"

-#ifdef _WIN32
-      ComError _       -> "COM error"
-#endif
-
-
+      DynIOError{}      -> "unknown IO error"

 
 userError       :: String  -> IOError
 
 userError       :: String  -> IOError

-userError str  =  IOError Nothing UserError "" str
-\end{code}
+userError str  =  UserError str

 
 

-Predicates on IOError; little effort made on these so far...
-
-\begin{code}
+-- ---------------------------------------------------------------------------
+-- Predicates on IOError

 
 isAlreadyExistsError :: IOError -> Bool
 
 isAlreadyExistsError :: IOError -> Bool

-isAlreadyExistsError (IOError _ AlreadyExists _ _) = True
-isAlreadyExistsError _                            = False
+isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True
+isAlreadyExistsError _                                             = False

 
 isAlreadyInUseError :: IOError -> Bool
 
 isAlreadyInUseError :: IOError -> Bool

-isAlreadyInUseError (IOError _ ResourceBusy _ _) = True
-isAlreadyInUseError _                           = False
+isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True
+isAlreadyInUseError _                                            = False

 
 isFullError :: IOError -> Bool
 
 isFullError :: IOError -> Bool

-isFullError (IOError _ ResourceExhausted _ _) = True
-isFullError _                                = False
+isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True
+isFullError _                                                 = False

 
 isEOFError :: IOError -> Bool
 
 isEOFError :: IOError -> Bool

-isEOFError (IOError _ EOF _ _) = True
-isEOFError _                   = False
+isEOFError (IOException (IOError _ EOF _ _ _)) = True
+isEOFError _                                   = False

 
 isIllegalOperation :: IOError -> Bool
 
 isIllegalOperation :: IOError -> Bool

-isIllegalOperation (IOError _ IllegalOperation _ _) = True
-isIllegalOperation _                               = False
+isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True
+isIllegalOperation _                                                = False

 
 isPermissionError :: IOError -> Bool
 
 isPermissionError :: IOError -> Bool

-isPermissionError (IOError _ PermissionDenied _ _) = True
-isPermissionError _                               = False
+isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True
+isPermissionError _                                                = False

 
 isDoesNotExistError :: IOError -> Bool
 
 isDoesNotExistError :: IOError -> Bool

-isDoesNotExistError (IOError _ NoSuchThing _ _) = True
-isDoesNotExistError _                           = False
+isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True
+isDoesNotExistError _                                           = False

 
 isUserError :: IOError -> Bool
 
 isUserError :: IOError -> Bool

-isUserError (IOError _ UserError _ _) = True
-isUserError _                        = False
-\end{code}
+isUserError (UserError _) = True
+isUserError _             = False

 
 

-Showing @IOError@s
+-- ---------------------------------------------------------------------------
+-- Showing IOErrors

 
 

-\begin{code}
-#ifdef __HUGS__
--- For now we give a fairly uninformative error message which just happens to
--- be like the ones that Hugs used to give.
-instance Show IOError where
-    showsPrec p (IOError hdl iot loc s) = showString s . showChar '\n'
-#else
-instance Show IOError where
-    showsPrec p (IOError hdl iot loc s) =
+instance Show IOException where
+    showsPrec p (IOError hdl iot loc s fn) =

       showsPrec p iot .
       showsPrec p iot .

-      showChar '\n' .

       (case loc of
          "" -> id
       (case loc of
          "" -> id

-        _  -> showString "Action: " . showString loc . showChar '\n') .
-      showHdl .
+        _  -> showString "\nAction: " . showString loc) .
+      (case hdl of
+        Nothing -> id
+       Just h  -> showString "\nHandle: " . showsPrec p h) .

       (case s of
         "" -> id
       (case s of
         "" -> id

-        _  -> showString "Reason: " . showString s)
-     where
-      showHdl = 
-       case hdl of
-        Nothing -> id
-       Just h  -> showString "Handle: " . showsPrec p h
-
-#endif
-\end{code}
-
-The @String@ part of an @IOError@ is platform-dependent.  However, to
-provide a uniform mechanism for distinguishing among errors within
-these broad categories, each platform-specific standard shall specify
-the exact strings to be used for particular errors.  For errors not
-explicitly mentioned in the standard, any descriptive string may be
-used.
-
-\begin{code}
-constructErrorAndFail :: String -> IO a
-constructErrorAndFail call_site
-  = constructError call_site >>= \ io_error ->
-    ioError io_error
-
-constructErrorAndFailWithInfo :: String -> String -> IO a
-constructErrorAndFailWithInfo call_site reason
-  = constructErrorMsg call_site (Just reason) >>= \ io_error ->
-    ioError io_error
-
-\end{code}
-
-This doesn't seem to be documented/spelled out anywhere,
-so here goes: (SOF)
-
-The implementation of the IO prelude uses various C stubs
-to do the actual interaction with the OS. The bandwidth
-\tr{C<->Haskell} is somewhat limited, so the general strategy
-for flaggging any errors (apart from possibly using the
-return code of the external call), is to set the @ghc_errtype@
-to a value that is one of the \tr{#define}s in @includes/error.h@.
-@ghc_errstr@ holds a character string providing error-specific
-information. Error constructing functions will then reach out
-and grab these values when generating
-
-\begin{code}
-constructError       :: String -> IO IOError
-constructError call_site = constructErrorMsg call_site Nothing
-
-constructErrorMsg            :: String -> Maybe String -> IO IOError
-constructErrorMsg call_site reason =
- CCALL(getErrType__)            >>= \ errtype ->
- CCALL(getErrStr__)             >>= \ str ->
- let
-  iot =
-   case (errtype::Int) of
-     ERR_ALREADYEXISTS          -> AlreadyExists
-     ERR_HARDWAREFAULT          -> HardwareFault
-     ERR_ILLEGALOPERATION       -> IllegalOperation
-     ERR_INAPPROPRIATETYPE      -> InappropriateType
-     ERR_INTERRUPTED            -> Interrupted
-     ERR_INVALIDARGUMENT        -> InvalidArgument
-     ERR_NOSUCHTHING            -> NoSuchThing
-     ERR_OTHERERROR             -> OtherError
-     ERR_PERMISSIONDENIED       -> PermissionDenied
-     ERR_PROTOCOLERROR          -> ProtocolError
-     ERR_RESOURCEBUSY           -> ResourceBusy
-     ERR_RESOURCEEXHAUSTED      -> ResourceExhausted
-     ERR_RESOURCEVANISHED       -> ResourceVanished
-     ERR_SYSTEMERROR            -> SystemError
-     ERR_TIMEEXPIRED            -> TimeExpired
-     ERR_UNSATISFIEDCONSTRAINTS -> UnsatisfiedConstraints
-     ERR_UNSUPPORTEDOPERATION   -> UnsupportedOperation
-     ERR_EOF                    -> EOF
-     _                          -> OtherError
-
-  msg = 
-   unpackCString str ++
-   (case iot of
-     OtherError -> "(error code: " ++ show errtype ++ ")"
-     _ -> "") ++
-   (case reason of
-      Nothing -> ""
-      Just m  -> ' ':m)
- in
- return (IOError Nothing iot call_site msg)
-\end{code}
-
-File names are specified using @FilePath@, a OS-dependent
-string that (hopefully, I guess) maps to an accessible file/object.
-
-\begin{code}
-type FilePath = String
-\end{code}
-
-%*********************************************************
-%*                                                     *
-\subsection{Types @Handle@, @Handle__@}
-%*                                                     *
-%*********************************************************
-
-The type for @Handle@ is defined rather than in @IOHandle@
-module, as the @IOError@ type uses it..all operations over
-a handles reside in @IOHandle@.
-
-\begin{code}
-
-#ifndef __HUGS__
-{-
- Sigh, the MVar ops in ConcBase depend on IO, the IO
- representation here depend on MVars for handles (when
- compiling in a concurrent way). Break the cycle by having
- the definition of MVars go here:
-
--}
-data MVar a = MVar (MVar# RealWorld a)
-
-{-
-  Double sigh - ForeignObj is needed here too to break a cycle.
--}
-data ForeignObj = ForeignObj ForeignObj#   -- another one
-instance CCallable ForeignObj
-instance CCallable ForeignObj#
-#endif /* ndef __HUGS__ */
-
-#if defined(__CONCURRENT_HASKELL__)
-newtype Handle = Handle (MVar Handle__)
-#else
-newtype Handle = Handle (MutableVar RealWorld Handle__)
-#endif
-
-{-
-  A Handle is represented by (a reference to) a record 
-  containing the state of the I/O port/device. We record
-  the following pieces of info:
-
-    * type (read,write,closed etc.)
-    * pointer to the external file object.
-    * buffering mode 
-    * user-friendly name (usually the
-      FilePath used when IO.openFile was called)
-
-Note: when a Handle is garbage collected, we want to flush its buffer
-and close the OS file handle, so as to free up a (precious) resource.
--}
-data Handle__
-  = Handle__ {
-      haFO__         :: FILE_OBJECT,
-      haType__        :: Handle__Type,
-      haBufferMode__  :: BufferMode,
-      haFilePath__    :: FilePath
-    }      
-
-{-
-  Internally, we classify handles as being one
-  of the following:
--}
-data Handle__Type
- = ErrorHandle  IOError
- | ClosedHandle
- | SemiClosedHandle
- | ReadHandle
- | WriteHandle
- | AppendHandle
- | ReadWriteHandle
-
-
--- handle types are 'show'ed when printing error msgs, so
--- we provide a more user-friendly Show instance for it
--- than the derived one.
-instance Show Handle__Type where
-  showsPrec p t =
-    case t of
-      ErrorHandle iot   -> showString "error " . showsPrec p iot
-      ClosedHandle      -> showString "closed"
-      SemiClosedHandle  -> showString "semi-closed"
-      ReadHandle        -> showString "readable"
-      WriteHandle       -> showString "writeable"
-      AppendHandle      -> showString "writeable (append)"
-      ReadWriteHandle   -> showString "read-writeable"
-
-instance Show Handle where 
-  showsPrec p (Handle h) = 
-    let
-#if defined(__CONCURRENT_HASKELL__)
-#ifdef __HUGS__
-     hdl_ = unsafePerformIO (primTakeMVar h)
-#else
-     -- (Big) SIGH: unfolded defn of takeMVar to avoid
-     -- an (oh-so) unfortunate module loop with PrelConc.
-     hdl_ = unsafePerformIO (IO $ \ s# ->
-            case h               of { MVar h# ->
-            case takeMVar# h# s# of { (# s2# , r #) -> 
-                   (# s2#, r #) }})
-#endif
-#else
-     hdl_ = unsafePerformIO (stToIO (readVar h))
-#endif
-    in
-    showChar '{' . 
-    showHdl (haType__ hdl_) 
-           (showString "loc=" . showString (haFilePath__ hdl_) . showChar ',' .
-            showString "type=" . showsPrec p (haType__ hdl_) . showChar ',' .
-            showString "buffering=" . showBufMode (haFO__ hdl_) (haBufferMode__ hdl_) . showString "}\n" )
-   where
-    showHdl :: Handle__Type -> ShowS -> ShowS
-    showHdl ht cont = 
-       case ht of
-        ClosedHandle  -> showsPrec p ht . showString "}\n"
-        ErrorHandle _ -> showsPrec p ht . showString "}\n"
-       _ -> cont
-       
-    showBufMode :: FILE_OBJECT -> BufferMode -> ShowS
-    showBufMode fo bmo =
-      case bmo of
-        NoBuffering   -> showString "none"
-       LineBuffering -> showString "line"
-       BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n)
-       BlockBuffering Nothing  -> showString "block " . showParen True (showsPrec p def)
-      where
-       def :: Int 
-       def = unsafePerformIO (CCALL(getBufSize) fo)
-
-mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
-mkBuffer__ fo sz_in_bytes = do
- chunk <- 
-  case sz_in_bytes of
-    0 -> return nullAddr  -- this has the effect of overwriting the pointer to the old buffer.
-    _ -> do
-     chunk <- CCALL(allocMemory__) sz_in_bytes
-     if chunk == nullAddr
-      then ioError (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
-      else return chunk
- CCALL(setBuf) fo chunk sz_in_bytes
-
-\end{code}
-
-%*********************************************************
-%*                                                     *
-\subsection[BufferMode]{Buffering modes}
-%*                                                     *
-%*********************************************************
-
-Three kinds of buffering are supported: line-buffering, 
-block-buffering or no-buffering.  These modes have the following
-effects. For output, items are written out from the internal
-buffer according to the buffer mode:
-
-\begin{itemize}
-\item[line-buffering]  the entire output buffer is written
-out whenever a newline is output, the output buffer overflows, 
-a flush is issued, or the handle is closed.
-
-\item[block-buffering] the entire output buffer is written out whenever 
-it overflows, a flush is issued, or the handle
-is closed.
-
-\item[no-buffering] output is written immediately, and never stored
-in the output buffer.
-\end{itemize}
-
-The output buffer is emptied as soon as it has been written out.
-
-Similarly, input occurs according to the buffer mode for handle {\em hdl}.
-\begin{itemize}
-\item[line-buffering] when the input buffer for {\em hdl} is not empty,
-the next item is obtained from the buffer;
-otherwise, when the input buffer is empty,
-characters up to and including the next newline
-character are read into the buffer.  No characters
-are available until the newline character is
-available.
-\item[block-buffering] when the input buffer for {\em hdl} becomes empty,
-the next block of data is read into this buffer.
-\item[no-buffering] the next input item is read and returned.
-\end{itemize}
-
-For most implementations, physical files will normally be block-buffered 
-and terminals will normally be line-buffered. (the IO interface provides
-operations for changing the default buffering of a handle tho.)
-
-\begin{code}
-data BufferMode  
- = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
-   deriving (Eq, Ord, Show)
-   {- Read instance defined in IO. -}
-
+        _  -> showString "\nReason: " . showString s) .
+      (case fn of
+        Nothing -> id
+        Just name -> showString "\nFile: " . showString name)

 \end{code}
 \end{code}