ghc/lib/std/PrelException.lhs

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