468dd49d416323d8c97483358a1dc9a05275880e
[ghc-base.git] / Control / Exception / Base.hs
1 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3
4 #include "Typeable.h"
5
6 -----------------------------------------------------------------------------
7 -- |
8 -- Module      :  Control.Exception.Base
9 -- Copyright   :  (c) The University of Glasgow 2001
10 -- License     :  BSD-style (see the file libraries/base/LICENSE)
11 -- 
12 -- Maintainer  :  libraries@haskell.org
13 -- Stability   :  experimental
14 -- Portability :  non-portable (extended exceptions)
15 --
16 -- Extensible exceptions, except for multiple handlers.
17 --
18 -----------------------------------------------------------------------------
19
20 module Control.Exception.Base (
21
22         -- * The Exception type
23 #ifdef __HUGS__
24         SomeException,
25 #else
26         SomeException(..),
27 #endif
28         Exception(..),
29         IOException,
30         ArithException(..),
31         ArrayException(..),
32         AssertionFailed(..),
33         AsyncException(..),
34
35 #if __GLASGOW_HASKELL__ || __HUGS__
36         NonTermination(..),
37         NestedAtomically(..),
38 #endif
39
40         BlockedOnDeadMVar(..),
41         BlockedIndefinitely(..),
42         Deadlock(..),
43         NoMethodError(..),
44         PatternMatchFail(..),
45         RecConError(..),
46         RecSelError(..),
47         RecUpdError(..),
48         ErrorCall(..),
49
50         -- * Throwing exceptions
51         throwIO,
52         throw,
53         ioError,
54 #ifdef __GLASGOW_HASKELL__
55         throwTo,
56 #endif
57
58         -- * Catching Exceptions
59
60         -- ** The @catch@ functions
61         catch,
62         catchJust,
63
64         -- ** The @handle@ functions
65         handle,
66         handleJust,
67
68         -- ** The @try@ functions
69         try,
70         tryJust,
71         onException,
72
73         -- ** The @evaluate@ function
74         evaluate,
75
76         -- ** The @mapException@ function
77         mapException,
78
79         -- * Asynchronous Exceptions
80
81         -- ** Asynchronous exception control
82
83         block,
84         unblock,
85         blocked,
86
87         -- * Assertions
88
89         assert,
90
91         -- * Utilities
92
93         bracket,
94         bracket_,
95         bracketOnError,
96
97         finally,
98
99 #ifdef __GLASGOW_HASKELL__
100         -- * Calls for GHC runtime
101         recSelError, recConError, irrefutPatError, runtimeError,
102         nonExhaustiveGuardsError, patError, noMethodBindingError,
103         nonTermination, nestedAtomically,
104 #endif
105   ) where
106
107 #ifdef __GLASGOW_HASKELL__
108 import GHC.Base
109 import GHC.IOBase
110 import GHC.Show
111 import GHC.IOBase
112 import GHC.Exception hiding ( Exception )
113 import GHC.Conc
114 #endif
115
116 #ifdef __HUGS__
117 import Prelude hiding (catch)
118 import Hugs.Prelude (ExitCode(..))
119 import Hugs.IOExts (unsafePerformIO)
120 import Hugs.Exception (SomeException(DynamicException, IOException,
121                                      ArithException, ArrayException, ExitException),
122                        evaluate, IOException, ArithException, ArrayException)
123 import qualified Hugs.Exception
124 #endif
125
126 import Data.Dynamic
127 import Data.Either
128 import Data.Maybe
129
130 #ifdef __NHC__
131 import qualified IO as H'98 (catch)
132 import IO              (bracket,ioError)
133 import DIOError         -- defn of IOError type
134 import System          (ExitCode())
135 import System.IO.Unsafe (unsafePerformIO)
136 import Unsafe.Coerce    (unsafeCoerce)
137
138 -- minimum needed for nhc98 to pretend it has Exceptions
139
140 {-
141 data Exception   = IOException    IOException
142                  | ArithException ArithException
143                  | ArrayException ArrayException
144                  | AsyncException AsyncException
145                  | ExitException  ExitCode
146                  deriving Show
147 -}
148 class ({-Typeable e,-} Show e) => Exception e where
149     toException   :: e -> SomeException
150     fromException :: SomeException -> Maybe e
151
152 data SomeException = forall e . Exception e => SomeException e
153
154 INSTANCE_TYPEABLE0(SomeException,someExceptionTc,"SomeException")
155
156 instance Show SomeException where
157     showsPrec p (SomeException e) = showsPrec p e
158 instance Exception SomeException where
159     toException se = se
160     fromException = Just
161
162 type IOException = IOError
163 instance Exception IOError where
164     toException                     = SomeException
165     fromException (SomeException e) = Just (unsafeCoerce e)
166
167 instance Exception ExitCode where
168     toException                     = SomeException
169     fromException (SomeException e) = Just (unsafeCoerce e)
170
171 data ArithException
172 data ArrayException
173 data AsyncException
174 data AssertionFailed
175 data PatternMatchFail
176 data NoMethodError
177 data Deadlock
178 data BlockedOnDeadMVar
179 data BlockedIndefinitely
180 data ErrorCall
181 data RecConError
182 data RecSelError
183 data RecUpdError
184 instance Show ArithException
185 instance Show ArrayException
186 instance Show AsyncException
187 instance Show AssertionFailed
188 instance Show PatternMatchFail
189 instance Show NoMethodError
190 instance Show Deadlock
191 instance Show BlockedOnDeadMVar
192 instance Show BlockedIndefinitely
193 instance Show ErrorCall
194 instance Show RecConError
195 instance Show RecSelError
196 instance Show RecUpdError
197
198 catch   :: Exception e
199         => IO a         -- ^ The computation to run
200         -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised
201         -> IO a
202 catch io h = H'98.catch  io  (h . fromJust . fromException . toException)
203
204 throwIO  :: Exception e => e -> IO a
205 throwIO   = ioError . fromJust . fromException . toException
206
207 throw    :: Exception e => e -> a
208 throw     = unsafePerformIO . throwIO
209
210 evaluate :: a -> IO a
211 evaluate x = x `seq` return x
212
213 assert :: Bool -> a -> a
214 assert True  x = x
215 assert False _ = throw (toException (UserError "" "Assertion failed"))
216
217 #endif
218
219 #ifdef __HUGS__
220 class (Typeable e, Show e) => Exception e where
221     toException   :: e -> SomeException
222     fromException :: SomeException -> Maybe e
223
224     toException e = DynamicException (toDyn e) (flip showsPrec e)
225     fromException (DynamicException dyn _) = fromDynamic dyn
226     fromException _ = Nothing
227
228 INSTANCE_TYPEABLE0(SomeException,someExceptionTc,"SomeException")
229 INSTANCE_TYPEABLE0(IOException,iOExceptionTc,"IOException")
230 INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")
231 INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException")
232 INSTANCE_TYPEABLE0(ExitCode,exitCodeTc,"ExitCode")
233 INSTANCE_TYPEABLE0(ErrorCall,errorCallTc,"ErrorCall")
234 INSTANCE_TYPEABLE0(AssertionFailed,assertionFailedTc,"AssertionFailed")
235 INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")
236 INSTANCE_TYPEABLE0(BlockedOnDeadMVar,blockedOnDeadMVarTc,"BlockedOnDeadMVar")
237 INSTANCE_TYPEABLE0(BlockedIndefinitely,blockedIndefinitelyTc,"BlockedIndefinitely")
238 INSTANCE_TYPEABLE0(Deadlock,deadlockTc,"Deadlock")
239
240 instance Exception SomeException where
241     toException se = se
242     fromException = Just
243
244 instance Exception IOException where
245     toException = IOException
246     fromException (IOException e) = Just e
247     fromException _ = Nothing
248
249 instance Exception ArrayException where
250     toException = ArrayException
251     fromException (ArrayException e) = Just e
252     fromException _ = Nothing
253
254 instance Exception ArithException where
255     toException = ArithException
256     fromException (ArithException e) = Just e
257     fromException _ = Nothing
258
259 instance Exception ExitCode where
260     toException = ExitException
261     fromException (ExitException e) = Just e
262     fromException _ = Nothing
263
264 data ErrorCall = ErrorCall String
265
266 instance Show ErrorCall where
267     showsPrec _ (ErrorCall err) = showString err
268
269 instance Exception ErrorCall where
270     toException (ErrorCall s) = Hugs.Exception.ErrorCall s
271     fromException (Hugs.Exception.ErrorCall s) = Just (ErrorCall s)
272     fromException _ = Nothing
273
274 data BlockedOnDeadMVar = BlockedOnDeadMVar
275 data BlockedIndefinitely = BlockedIndefinitely
276 data Deadlock = Deadlock
277 data AssertionFailed = AssertionFailed String
278 data AsyncException
279   = StackOverflow
280   | HeapOverflow
281   | ThreadKilled
282   | UserInterrupt
283   deriving (Eq, Ord)
284
285 instance Show BlockedOnDeadMVar where
286     showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"
287
288 instance Show BlockedIndefinitely where
289     showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"
290
291 instance Show Deadlock where
292     showsPrec _ Deadlock = showString "<<deadlock>>"
293
294 instance Show AssertionFailed where
295     showsPrec _ (AssertionFailed err) = showString err
296
297 instance Show AsyncException where
298     showsPrec _ StackOverflow   = showString "stack overflow"
299     showsPrec _ HeapOverflow    = showString "heap overflow"
300     showsPrec _ ThreadKilled    = showString "thread killed"
301     showsPrec _ UserInterrupt   = showString "user interrupt"
302
303 instance Exception BlockedOnDeadMVar
304 instance Exception BlockedIndefinitely
305 instance Exception Deadlock
306 instance Exception AssertionFailed
307 instance Exception AsyncException
308
309 throw :: Exception e => e -> a
310 throw e = Hugs.Exception.throw (toException e)
311
312 throwIO :: Exception e => e -> IO a
313 throwIO e = Hugs.Exception.throwIO (toException e)
314 #endif
315
316 #ifndef __GLASGOW_HASKELL__
317 -- Dummy definitions for implementations lacking asynchonous exceptions
318
319 block   :: IO a -> IO a
320 block    = id
321 unblock :: IO a -> IO a
322 unblock  = id
323 blocked :: IO Bool
324 blocked  = return False
325 #endif
326
327 -----------------------------------------------------------------------------
328 -- Catching exceptions
329
330 -- |This is the simplest of the exception-catching functions.  It
331 -- takes a single argument, runs it, and if an exception is raised
332 -- the \"handler\" is executed, with the value of the exception passed as an
333 -- argument.  Otherwise, the result is returned as normal.  For example:
334 --
335 -- >   catch (openFile f ReadMode)
336 -- >       (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e))
337 --
338 -- For catching exceptions in pure (non-'IO') expressions, see the
339 -- function 'evaluate'.
340 --
341 -- Note that due to Haskell\'s unspecified evaluation order, an
342 -- expression may return one of several possible exceptions: consider
343 -- the expression @error \"urk\" + 1 \`div\` 0@.  Does
344 -- 'catch' execute the handler passing
345 -- @ErrorCall \"urk\"@, or @ArithError DivideByZero@?
346 --
347 -- The answer is \"either\": 'catch' makes a
348 -- non-deterministic choice about which exception to catch.  If you
349 -- call it again, you might get a different exception back.  This is
350 -- ok, because 'catch' is an 'IO' computation.
351 --
352 -- Note that 'catch' catches all types of exceptions, and is generally
353 -- used for \"cleaning up\" before passing on the exception using
354 -- 'throwIO'.  It is not good practice to discard the exception and
355 -- continue, without first checking the type of the exception (it
356 -- might be a 'ThreadKilled', for example).  In this case it is usually better
357 -- to use 'catchJust' and select the kinds of exceptions to catch.
358 --
359 -- Also note that the "Prelude" also exports a function called
360 -- 'Prelude.catch' with a similar type to 'Control.Exception.catch',
361 -- except that the "Prelude" version only catches the IO and user
362 -- families of exceptions (as required by Haskell 98).
363 --
364 -- We recommend either hiding the "Prelude" version of 'Prelude.catch'
365 -- when importing "Control.Exception":
366 --
367 -- > import Prelude hiding (catch)
368 --
369 -- or importing "Control.Exception" qualified, to avoid name-clashes:
370 --
371 -- > import qualified Control.Exception as C
372 --
373 -- and then using @C.catch@
374 --
375 #ifndef __NHC__
376 catch   :: Exception e
377         => IO a         -- ^ The computation to run
378         -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised
379         -> IO a
380 #if __GLASGOW_HASKELL__
381 catch = GHC.IOBase.catchException
382 #elif __HUGS__
383 catch m h = Hugs.Exception.catchException m h'
384   where h' e = case fromException e of
385             Just e' -> h e'
386             Nothing -> throwIO e
387 #endif
388 #endif
389
390 -- | The function 'catchJust' is like 'catch', but it takes an extra
391 -- argument which is an /exception predicate/, a function which
392 -- selects which type of exceptions we\'re interested in.
393 --
394 -- >   result <- catchJust errorCalls thing_to_try handler
395 --
396 -- Any other exceptions which are not matched by the predicate
397 -- are re-raised, and may be caught by an enclosing
398 -- 'catch' or 'catchJust'.
399 catchJust
400         :: Exception e
401         => (e -> Maybe b)         -- ^ Predicate to select exceptions
402         -> IO a                   -- ^ Computation to run
403         -> (b -> IO a)            -- ^ Handler
404         -> IO a
405 catchJust p a handler = catch a handler'
406   where handler' e = case p e of
407                         Nothing -> throw e
408                         Just b  -> handler b
409
410 -- | A version of 'catch' with the arguments swapped around; useful in
411 -- situations where the code for the handler is shorter.  For example:
412 --
413 -- >   do handle (\e -> exitWith (ExitFailure 1)) $
414 -- >      ...
415 handle     :: Exception e => (e -> IO a) -> IO a -> IO a
416 handle     =  flip catch
417
418 -- | A version of 'catchJust' with the arguments swapped around (see
419 -- 'handle').
420 handleJust :: Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
421 handleJust p =  flip (catchJust p)
422
423 -----------------------------------------------------------------------------
424 -- 'mapException'
425
426 -- | This function maps one exception into another as proposed in the
427 -- paper \"A semantics for imprecise exceptions\".
428
429 -- Notice that the usage of 'unsafePerformIO' is safe here.
430
431 mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a
432 mapException f v = unsafePerformIO (catch (evaluate v)
433                                           (\x -> throw (f x)))
434
435 -----------------------------------------------------------------------------
436 -- 'try' and variations.
437
438 -- | Similar to 'catch', but returns an 'Either' result which is
439 -- @('Right' a)@ if no exception was raised, or @('Left' e)@ if an
440 -- exception was raised and its value is @e@.
441 --
442 -- >  try a = catch (Right `liftM` a) (return . Left)
443 --
444 -- Note: as with 'catch', it is only polite to use this variant if you intend
445 -- to re-throw the exception after performing whatever cleanup is needed.
446 -- Otherwise, 'tryJust' is generally considered to be better.
447 --
448 -- Also note that "System.IO.Error" also exports a function called
449 -- 'System.IO.Error.try' with a similar type to 'Control.Exception.try',
450 -- except that it catches only the IO and user families of exceptions
451 -- (as required by the Haskell 98 @IO@ module).
452
453 try :: Exception e => IO a -> IO (Either e a)
454 try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))
455
456 -- | A variant of 'try' that takes an exception predicate to select
457 -- which exceptions are caught (c.f. 'catchJust').  If the exception
458 -- does not match the predicate, it is re-thrown.
459 tryJust :: Exception e => (e -> Maybe b) -> IO a -> IO (Either b a)
460 tryJust p a = do
461   r <- try a
462   case r of
463         Right v -> return (Right v)
464         Left  e -> case p e of
465                         Nothing -> throw e
466                         Just b  -> return (Left b)
467
468 onException :: IO a -> IO b -> IO a
469 onException io what = io `catch` \e -> do what
470                                           throw (e :: SomeException)
471
472 -----------------------------------------------------------------------------
473 -- Some Useful Functions
474
475 -- | When you want to acquire a resource, do some work with it, and
476 -- then release the resource, it is a good idea to use 'bracket',
477 -- because 'bracket' will install the necessary exception handler to
478 -- release the resource in the event that an exception is raised
479 -- during the computation.  If an exception is raised, then 'bracket' will
480 -- re-raise the exception (after performing the release).
481 --
482 -- A common example is opening a file:
483 --
484 -- > bracket
485 -- >   (openFile "filename" ReadMode)
486 -- >   (hClose)
487 -- >   (\handle -> do { ... })
488 --
489 -- The arguments to 'bracket' are in this order so that we can partially apply
490 -- it, e.g.:
491 --
492 -- > withFile name mode = bracket (openFile name mode) hClose
493 --
494 #ifndef __NHC__
495 bracket
496         :: IO a         -- ^ computation to run first (\"acquire resource\")
497         -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
498         -> (a -> IO c)  -- ^ computation to run in-between
499         -> IO c         -- returns the value from the in-between computation
500 bracket before after thing =
501   block (do
502     a <- before
503     r <- unblock (thing a) `onException` after a
504     after a
505     return r
506  )
507 #endif
508
509 -- | A specialised variant of 'bracket' with just a computation to run
510 -- afterward.
511 --
512 finally :: IO a         -- ^ computation to run first
513         -> IO b         -- ^ computation to run afterward (even if an exception
514                         -- was raised)
515         -> IO a         -- returns the value from the first computation
516 a `finally` sequel =
517   block (do
518     r <- unblock a `onException` sequel
519     sequel
520     return r
521   )
522
523 -- | A variant of 'bracket' where the return value from the first computation
524 -- is not required.
525 bracket_ :: IO a -> IO b -> IO c -> IO c
526 bracket_ before after thing = bracket before (const after) (const thing)
527
528 -- | Like bracket, but only performs the final action if there was an
529 -- exception raised by the in-between computation.
530 bracketOnError
531         :: IO a         -- ^ computation to run first (\"acquire resource\")
532         -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
533         -> (a -> IO c)  -- ^ computation to run in-between
534         -> IO c         -- returns the value from the in-between computation
535 bracketOnError before after thing =
536   block (do
537     a <- before
538     unblock (thing a) `onException` after a
539   )
540
541 #if !(__GLASGOW_HASKELL__ || __NHC__)
542 assert :: Bool -> a -> a
543 assert True x = x
544 assert False _ = throw (AssertionFailed "")
545 #endif
546
547 -----
548
549 #if __GLASGOW_HASKELL__ || __HUGS__
550 data PatternMatchFail = PatternMatchFail String
551 INSTANCE_TYPEABLE0(PatternMatchFail,patternMatchFailTc,"PatternMatchFail")
552
553 instance Show PatternMatchFail where
554     showsPrec _ (PatternMatchFail err) = showString err
555
556 #ifdef __HUGS__
557 instance Exception PatternMatchFail where
558     toException (PatternMatchFail err) = Hugs.Exception.PatternMatchFail err
559     fromException (Hugs.Exception.PatternMatchFail err) = Just (PatternMatchFail err)
560     fromException _ = Nothing
561 #else
562 instance Exception PatternMatchFail
563 #endif
564
565 -----
566
567 data RecSelError = RecSelError String
568 INSTANCE_TYPEABLE0(RecSelError,recSelErrorTc,"RecSelError")
569
570 instance Show RecSelError where
571     showsPrec _ (RecSelError err) = showString err
572
573 #ifdef __HUGS__
574 instance Exception RecSelError where
575     toException (RecSelError err) = Hugs.Exception.RecSelError err
576     fromException (Hugs.Exception.RecSelError err) = Just (RecSelError err)
577     fromException _ = Nothing
578 #else
579 instance Exception RecSelError
580 #endif
581
582 -----
583
584 data RecConError = RecConError String
585 INSTANCE_TYPEABLE0(RecConError,recConErrorTc,"RecConError")
586
587 instance Show RecConError where
588     showsPrec _ (RecConError err) = showString err
589
590 #ifdef __HUGS__
591 instance Exception RecConError where
592     toException (RecConError err) = Hugs.Exception.RecConError err
593     fromException (Hugs.Exception.RecConError err) = Just (RecConError err)
594     fromException _ = Nothing
595 #else
596 instance Exception RecConError
597 #endif
598
599 -----
600
601 data RecUpdError = RecUpdError String
602 INSTANCE_TYPEABLE0(RecUpdError,recUpdErrorTc,"RecUpdError")
603
604 instance Show RecUpdError where
605     showsPrec _ (RecUpdError err) = showString err
606
607 #ifdef __HUGS__
608 instance Exception RecUpdError where
609     toException (RecUpdError err) = Hugs.Exception.RecUpdError err
610     fromException (Hugs.Exception.RecUpdError err) = Just (RecUpdError err)
611     fromException _ = Nothing
612 #else
613 instance Exception RecUpdError
614 #endif
615
616 -----
617
618 data NoMethodError = NoMethodError String
619 INSTANCE_TYPEABLE0(NoMethodError,noMethodErrorTc,"NoMethodError")
620
621 instance Show NoMethodError where
622     showsPrec _ (NoMethodError err) = showString err
623
624 #ifdef __HUGS__
625 instance Exception NoMethodError where
626     toException (NoMethodError err) = Hugs.Exception.NoMethodError err
627     fromException (Hugs.Exception.NoMethodError err) = Just (NoMethodError err)
628     fromException _ = Nothing
629 #else
630 instance Exception NoMethodError
631 #endif
632
633 -----
634
635 data NonTermination = NonTermination
636 INSTANCE_TYPEABLE0(NonTermination,nonTerminationTc,"NonTermination")
637
638 instance Show NonTermination where
639     showsPrec _ NonTermination = showString "<<loop>>"
640
641 #ifdef __HUGS__
642 instance Exception NonTermination where
643     toException NonTermination = Hugs.Exception.NonTermination
644     fromException Hugs.Exception.NonTermination = Just NonTermination
645     fromException _ = Nothing
646 #else
647 instance Exception NonTermination
648 #endif
649
650 -----
651
652 data NestedAtomically = NestedAtomically
653 INSTANCE_TYPEABLE0(NestedAtomically,nestedAtomicallyTc,"NestedAtomically")
654
655 instance Show NestedAtomically where
656     showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested"
657
658 instance Exception NestedAtomically
659
660 -----
661
662 instance Exception Dynamic
663
664 #endif /* __GLASGOW_HASKELL__ || __HUGS__ */
665
666 #ifdef __GLASGOW_HASKELL__
667 recSelError, recConError, irrefutPatError, runtimeError,
668              nonExhaustiveGuardsError, patError, noMethodBindingError
669         :: Addr# -> a   -- All take a UTF8-encoded C string
670
671 recSelError              s = throw (RecSelError ("No match in record selector "
672                                                  ++ unpackCStringUtf8# s))  -- No location info unfortunately
673 runtimeError             s = error (unpackCStringUtf8# s)                   -- No location info unfortunately
674
675 nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
676 irrefutPatError          s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
677 recConError              s = throw (RecConError      (untangle s "Missing field in record construction"))
678 noMethodBindingError     s = throw (NoMethodError    (untangle s "No instance nor default method for class operation"))
679 patError                 s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
680
681 -- GHC's RTS calls this
682 nonTermination :: SomeException
683 nonTermination = toException NonTermination
684
685 -- GHC's RTS calls this
686 nestedAtomically :: SomeException
687 nestedAtomically = toException NestedAtomically
688 #endif