ghc/lib/std/PrelException.lhs

   1 % -----------------------------------------------------------------------------
   2 % $Id: PrelException.lhs,v 1.21 2000/06/18 21:12:31 panne Exp $
   3 %
   4 % (c) The GRAP/AQUA Project, Glasgow University, 1998
   5 %
   6
   7 Exceptions and exception-handling functions.
   8
   9 \begin{code}
  10 {-# OPTIONS -fno-implicit-prelude #-}
  11
  12 #ifndef __HUGS__
  13 module PrelException where
  14
  15 import PrelList
  16 import PrelBase
  17 import PrelMaybe
  18 import PrelShow
  19 import PrelIOBase
  20 import PrelST           ( STret(..) )
  21 import PrelDynamic
  22 import PrelGHC
  23 #endif
  24 \end{code}
  25
  26 %*********************************************************
  27 %*                                                      *
  28 \subsection{Exception datatype and operations}
  29 %*                                                      *
  30 %*********************************************************
  31
  32 \begin{code}
  33 data Exception
  34   = IOException         IOError         -- IO exceptions (from 'ioError')
  35   | ArithException      ArithException  -- Arithmetic exceptions
  36   | ArrayException      ArrayException  -- Array-related exceptions
  37   | ErrorCall           String          -- Calls to 'error'
  38   | NoMethodError       String          -- A non-existent method was invoked
  39   | PatternMatchFail    String          -- A pattern match / guard failure
  40   | RecSelError         String          -- Selecting a non-existent field
  41   | RecConError         String          -- Field missing in record construction
  42   | RecUpdError         String          -- Record doesn't contain updated field
  43   | AssertionFailed     String          -- Assertions
  44   | DynException        Dynamic         -- Dynamic exceptions
  45   | AsyncException      AsyncException  -- Externally generated errors
  46   | PutFullMVar                         -- Put on a full MVar
  47   | BlockedOnDeadMVar                   -- Blocking on a dead MVar
  48   | NonTermination
  49
  50 data ArithException
  51   = Overflow
  52   | Underflow
  53   | LossOfPrecision
  54   | DivideByZero
  55   | Denormal
  56   deriving (Eq, Ord)
  57
  58 data AsyncException
  59   = StackOverflow
  60   | HeapOverflow
  61   | ThreadKilled
  62   deriving (Eq, Ord)
  63
  64 data ArrayException
  65   = IndexOutOfBounds    String          -- out-of-range array access
  66   | UndefinedElement    String          -- evaluating an undefined element
  67   deriving (Eq, Ord)
  68
  69 stackOverflow, heapOverflow :: Exception -- for the RTS
  70 stackOverflow = AsyncException StackOverflow
  71 heapOverflow  = AsyncException HeapOverflow
  72
  73 instance Show ArithException where
  74   showsPrec _ Overflow        = showString "arithmetic overflow"
  75   showsPrec _ Underflow       = showString "arithmetic underflow"
  76   showsPrec _ LossOfPrecision = showString "loss of precision"
  77   showsPrec _ DivideByZero    = showString "divide by zero"
  78   showsPrec _ Denormal        = showString "denormal"
  79
  80 instance Show AsyncException where
  81   showsPrec _ StackOverflow   = showString "stack overflow"
  82   showsPrec _ HeapOverflow    = showString "heap overflow"
  83   showsPrec _ ThreadKilled    = showString "thread killed"
  84
  85 instance Show ArrayException where
  86   showsPrec _ (IndexOutOfBounds s)
  87         = showString "array index out of range"
  88         . (if not (null s) then showString ": " . showString s
  89                            else id)
  90   showsPrec _ (UndefinedElement s)
  91         = showString "undefined array element"
  92         . (if not (null s) then showString ": " . showString s
  93                            else id)
  94
  95 instance Show Exception where
  96   showsPrec _ (IOException err)          = shows err
  97   showsPrec _ (ArithException err)       = shows err
  98   showsPrec _ (ArrayException err)       = shows err
  99   showsPrec _ (ErrorCall err)            = showString err
 100   showsPrec _ (NoMethodError err)        = showString err
 101   showsPrec _ (PatternMatchFail err)     = showString err
 102   showsPrec _ (RecSelError err)          = showString err
 103   showsPrec _ (RecConError err)          = showString err
 104   showsPrec _ (RecUpdError err)          = showString err
 105   showsPrec _ (AssertionFailed err)      = showString err
 106   showsPrec _ (AsyncException e)         = shows e
 107   showsPrec _ (DynException _err)        = showString "unknown exception"
 108   showsPrec _ (PutFullMVar)              = showString "putMVar: full MVar"
 109   showsPrec _ (BlockedOnDeadMVar)        = showString "thread blocked indefinitely"
 110   showsPrec _ (NonTermination)           = showString "<<loop>>"
 111 \end{code}
 112
 113 %*********************************************************
 114 %*                                                      *
 115 \subsection{Primitive catch and throw}
 116 %*                                                      *
 117 %*********************************************************
 118
 119 \begin{code}
 120 throw :: Exception -> a
 121
 122 #ifdef __HUGS__
 123 throw = primRaise
 124 #else
 125 throw exception = raise# exception
 126 #endif
 127 \end{code}
 128
 129 catchException used to handle the passing around of the state to the
 130 action and the handler.  This turned out to be a bad idea - it meant
 131 that we had to wrap both arguments in thunks so they could be entered
 132 as normal (remember IO returns an unboxed pair...).
 133
 134 Now catch# has type
 135
 136     catch# :: IO a -> (b -> IO a) -> IO a
 137
 138 (well almost; the compiler doesn't know about the IO newtype so we
 139 have to work around that in the definition of catchException below).
 140
 141 \begin{code}
 142 catchException :: IO a -> (Exception -> IO a) -> IO a
 143 #ifdef __HUGS__
 144 catchException m k =  ST (\s -> unST m s `primCatch'` \ err -> unST (k err) s)
 145 #else
 146 catchException (IO m) k =  IO $ \s -> catch# m (\ex -> unIO (k ex)) s
 147 #endif
 148
 149 catch           :: IO a -> (IOError -> IO a) -> IO a
 150 catch m k       =  catchException m handler
 151   where handler (IOException err) = k err
 152         handler other             = throw other
 153
 154 catchNonIO      :: IO a -> (Exception -> IO a) -> IO a
 155 catchNonIO m k  =  catchException m handler
 156   where handler (IOException err) = ioError err
 157         handler other             = k other
 158 \end{code}
 159
 160
 161 %*********************************************************
 162 %*                                                      *
 163 \subsection{Try and bracket}
 164 %*                                                      *
 165 %*********************************************************
 166
 167 The construct @try comp@ exposes errors which occur within a
 168 computation, and which are not fully handled.  It always succeeds.
 169
 170 \begin{code}
 171 try            :: IO a -> IO (Either IOError a)
 172 try f          =  catch (do r <- f
 173                             return (Right r))
 174                         (return . Left)
 175
 176 bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
 177 bracket before after m = do
 178         x  <- before
 179         rs <- try (m x)
 180         after x
 181         case rs of
 182            Right r -> return r
 183            Left  e -> ioError e
 184
 185 -- variant of the above where middle computation doesn't want x
 186 bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
 187 bracket_ before after m = do
 188          x  <- before
 189          rs <- try m
 190          after x
 191          case rs of
 192             Right r -> return r
 193             Left  e -> ioError e
 194 \end{code}
 195
 196
 197 %*********************************************************
 198 %*                                                      *
 199 \subsection{ioError}
 200 %*                                                      *
 201 %*********************************************************
 202
 203 Why is this stuff here?  To avoid recursive module dependencies of
 204 course.
 205
 206 \begin{code}
 207 ioError         :: IOError -> IO a
 208 ioError err     =  IO $ \s -> throw (IOException err) s
 209         -- (ioError e) isn't an exception; we only throw
 210         -- the exception when applied to a world
 211 \end{code}
 212
 213 %*********************************************************
 214 %*                                                      *
 215 \subsection{Controlling asynchronous exception delivery}
 216 %*                                                      *
 217 %*********************************************************
 218
 219 \begin{code}
 220 #ifndef __HUGS__
 221 blockAsyncExceptions :: IO a -> IO a
 222 blockAsyncExceptions (IO io) = IO $ blockAsyncExceptions# io
 223
 224 unblockAsyncExceptions :: IO a -> IO a
 225 unblockAsyncExceptions (IO io) = IO $ unblockAsyncExceptions# io
 226 #else
 227 -- Not implemented yet in Hugs.
 228 blockAsyncExceptions :: IO a -> IO a
 229 blockAsyncExceptions (IO io) = IO io
 230
 231 unblockAsyncExceptions :: IO a -> IO a
 232 unblockAsyncExceptions (IO io) = IO io
 233 #endif
 234 \end{code}
 235