+ 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
+
+-- -----------------------------------------------------------------------------
+-- 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