X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FException.hs;h=13b6cac40491aabb95ffbfe12e26038a079ee0d8;hb=a2bcd1899dea9b266b7c795e391f658985deda2e;hp=5362610db47b7241ceddc38339d9b4e3350e724b;hpb=ca42310d56e946d3e266ae89b525f1d297ce15c0;p=ghc-base.git diff --git a/Control/Exception.hs b/Control/Exception.hs index 5362610..13b6cac 100644 --- a/Control/Exception.hs +++ b/Control/Exception.hs @@ -1,3 +1,7 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +#include "Typeable.h" + ----------------------------------------------------------------------------- -- | -- Module : Control.Exception @@ -6,130 +10,197 @@ -- -- Maintainer : libraries@haskell.org -- Stability : experimental --- Portability : non-portable +-- Portability : non-portable (extended exceptions) -- -- This module provides support for raising and catching both built-in -- and user-defined exceptions. -- +-- In addition to exceptions thrown by 'IO' operations, exceptions may +-- be thrown by pure code (imprecise exceptions) or by external events +-- (asynchronous exceptions), but may only be caught in the 'IO' monad. +-- For more details, see: +-- +-- * /A semantics for imprecise exceptions/, by Simon Peyton Jones, +-- Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson, +-- in /PLDI'99/. +-- +-- * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton +-- Jones, Andy Moran and John Reppy, in /PLDI'01/. +-- ----------------------------------------------------------------------------- module Control.Exception ( - -- * The Exception type - Exception(..), -- instance Eq, Ord, Show, Typeable - IOException, -- instance Eq, Ord, Show, Typeable - ArithException(..), -- instance Eq, Ord, Show, Typeable - ArrayException(..), -- instance Eq, Ord, Show, Typeable - AsyncException(..), -- instance Eq, Ord, Show, Typeable - - -- * Throwing exceptions - throwIO, -- :: Exception -> IO a - throw, -- :: Exception -> a - ioError, -- :: IOError -> IO a + -- * The Exception type + SomeException(..), + Exception(..), -- instance Eq, Ord, Show, Typeable + IOException, -- instance Eq, Ord, Show, Typeable + ArithException(..), -- instance Eq, Ord, Show, Typeable + ArrayException(..), -- instance Eq, Ord, Show, Typeable + AssertionFailed(..), + AsyncException(..), -- instance Eq, Ord, Show, Typeable + NonTermination(..), nonTermination, + BlockedOnDeadMVar(..), + BlockedIndefinitely(..), + NestedAtomically(..), nestedAtomically, + Deadlock(..), + NoMethodError(..), + PatternMatchFail(..), + RecConError(..), + RecSelError(..), + RecUpdError(..), + ErrorCall(..), + + -- * Throwing exceptions + throwIO, -- :: Exception -> IO a + throw, -- :: Exception -> a + ioError, -- :: IOError -> IO a #ifdef __GLASGOW_HASKELL__ - throwTo, -- :: ThreadId -> Exception -> a + throwTo, -- :: ThreadId -> Exception -> a #endif - -- * Catching Exceptions - - -- |There are several functions for catching and examining - -- exceptions; all of them may only be used from within the - -- 'IO' monad. + -- * Catching Exceptions - -- ** The @catch@ functions - catch, -- :: IO a -> (Exception -> IO a) -> IO a - catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a + -- |There are several functions for catching and examining + -- exceptions; all of them may only be used from within the + -- 'IO' monad. - -- ** The @handle@ functions - handle, -- :: (Exception -> IO a) -> IO a -> IO a - handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a + -- ** The @catch@ functions + catch, -- :: IO a -> (Exception -> IO a) -> IO a + catches, Handler(..), + catchAny, + catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a - -- ** The @try@ functions - try, -- :: IO a -> IO (Either Exception a) - tryJust, -- :: (Exception -> Maybe b) -> a -> IO (Either b a) + -- ** The @handle@ functions + handle, -- :: (Exception -> IO a) -> IO a -> IO a + handleAny, + handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a - -- ** The @evaluate@ function - evaluate, -- :: a -> IO a + -- ** The @try@ functions + try, -- :: IO a -> IO (Either Exception a) + tryJust, -- :: (Exception -> Maybe b) -> a -> IO (Either b a) + ignoreExceptions, + onException, - -- ** The @mapException@ function - mapException, -- :: (Exception -> Exception) -> a -> a + -- ** The @evaluate@ function + evaluate, -- :: a -> IO a - -- ** Exception predicates - - -- $preds + -- ** The @mapException@ function + mapException, -- :: (Exception -> Exception) -> a -> a - ioErrors, -- :: Exception -> Maybe IOError - arithExceptions, -- :: Exception -> Maybe ArithException - errorCalls, -- :: Exception -> Maybe String - dynExceptions, -- :: Exception -> Maybe Dynamic - assertions, -- :: Exception -> Maybe String - asyncExceptions, -- :: Exception -> Maybe AsyncException - userErrors, -- :: Exception -> Maybe String + -- * Asynchronous Exceptions - -- * Dynamic exceptions + -- $async - -- $dynamic - throwDyn, -- :: Typeable ex => ex -> b -#ifdef __GLASGOW_HASKELL__ - throwDynTo, -- :: Typeable ex => ThreadId -> ex -> b -#endif - catchDyn, -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a - - -- * Asynchronous Exceptions - - -- $async + -- ** Asynchronous exception control - -- ** Asynchronous exception control - - -- |The following two functions allow a thread to control delivery of - -- asynchronous exceptions during a critical region. + -- |The following two functions allow a thread to control delivery of + -- asynchronous exceptions during a critical region. block, -- :: IO a -> IO a unblock, -- :: IO a -> IO a + blocked, -- :: IO Bool + + -- *** Applying @block@ to an exception handler + + -- $block_handler - -- *** Applying @block@ to an exception handler + -- *** Interruptible operations - -- $block_handler + -- $interruptible - -- *** Interruptible operations + -- * Assertions - -- $interruptible + assert, -- :: Bool -> a -> a - -- * Assertions + -- * Utilities - assert, -- :: Bool -> a -> a + bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO () + bracket_, -- :: IO a -> IO b -> IO c -> IO () + bracketOnError, - -- * Utilities + finally, -- :: IO a -> IO b -> IO a - bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO () - bracket_, -- :: IO a -> IO b -> IO c -> IO () - bracketOnError, + recSelError, recConError, irrefutPatError, runtimeError, + nonExhaustiveGuardsError, patError, noMethodBindingError, - finally, -- :: IO a -> IO b -> IO a - #ifdef __GLASGOW_HASKELL__ - setUncaughtExceptionHandler, -- :: (Exception -> IO ()) -> IO () - getUncaughtExceptionHandler -- :: IO (Exception -> IO ()) + setUncaughtExceptionHandler, -- :: (Exception -> IO ()) -> IO () + getUncaughtExceptionHandler -- :: IO (Exception -> IO ()) #endif ) where #ifdef __GLASGOW_HASKELL__ -import GHC.Base ( assert ) -import GHC.Exception as ExceptionBase hiding (catch) -import GHC.Conc ( throwTo, ThreadId ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import GHC.Base +import GHC.IOBase +import {-# SOURCE #-} GHC.Handle +import GHC.List +import GHC.Num +import GHC.Show +import GHC.IOBase as ExceptionBase +import GHC.Exception hiding ( Exception ) +import {-# SOURCE #-} GHC.Conc ( ThreadId(ThreadId) ) import Foreign.C.String ( CString, withCString ) -import System.IO ( stdout, hFlush ) #endif #ifdef __HUGS__ -import Hugs.Exception as ExceptionBase +import Hugs.Exception as ExceptionBase #endif -import Prelude hiding ( catch ) -import System.IO.Error hiding ( catch, try ) -import System.IO.Unsafe (unsafePerformIO) import Data.Dynamic +import Data.Either +import Data.Maybe + +#ifdef __NHC__ +import qualified System.IO.Error as H'98 (catch) +import System.IO.Error (ioError) +import IO (bracket) +import DIOError -- defn of IOError type +import System (ExitCode()) + +-- minimum needed for nhc98 to pretend it has Exceptions +data Exception = IOException IOException + | ArithException ArithException + | ArrayException ArrayException + | AsyncException AsyncException + | ExitException ExitCode + deriving Show +type IOException = IOError +data ArithException +data ArrayException +data AsyncException +instance Show ArithException +instance Show ArrayException +instance Show AsyncException + +catch :: IO a -> (Exception -> IO a) -> IO a +a `catch` b = a `H'98.catch` (b . IOException) + +throwIO :: Exception -> IO a +throwIO (IOException e) = ioError e +throwIO _ = ioError (UserError "Control.Exception.throwIO" + "unknown exception") +throw :: Exception -> a +throw = unsafePerformIO . throwIO + +evaluate :: a -> IO a +evaluate x = x `seq` return x + +assert :: Bool -> a -> a +assert True x = x +assert False _ = throw (IOException (UserError "" "Assertion failed")) +#endif + +#ifndef __GLASGOW_HASKELL__ +-- Dummy definitions for implementations lacking asynchonous exceptions + +block :: IO a -> IO a +block = id +unblock :: IO a -> IO a +unblock = id +blocked :: IO Bool +blocked = return False +#endif ----------------------------------------------------------------------------- -- Catching exceptions @@ -140,7 +211,7 @@ import Data.Dynamic -- argument. Otherwise, the result is returned as normal. For example: -- -- > catch (openFile f ReadMode) --- > (\e -> hPutStr stderr (\"Couldn\'t open \"++f++\": \" ++ show e)) +-- > (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e)) -- -- For catching exceptions in pure (non-'IO') expressions, see the -- function 'evaluate'. @@ -166,23 +237,41 @@ import Data.Dynamic -- Also note that the "Prelude" also exports a function called -- 'Prelude.catch' with a similar type to 'Control.Exception.catch', -- except that the "Prelude" version only catches the IO and user --- families of exceptions (as required by Haskell 98). We recommend --- either hiding the "Prelude" version of --- 'Prelude.catch' when importing --- "Control.Exception", or importing --- "Control.Exception" qualified, to avoid name-clashes. - -catch :: IO a -- ^ The computation to run - -> (Exception -> IO a) -- ^ Handler to invoke if an exception is raised - -> IO a -catch = ExceptionBase.catchException - +-- families of exceptions (as required by Haskell 98). +-- +-- We recommend either hiding the "Prelude" version of 'Prelude.catch' +-- when importing "Control.Exception": +-- +-- > import Prelude hiding (catch) +-- +-- or importing "Control.Exception" qualified, to avoid name-clashes: +-- +-- > import qualified Control.Exception as C +-- +-- and then using @C.catch@ +-- +#ifndef __NHC__ +catch :: Exception e + => IO a -- ^ The computation to run + -> (e -> IO a) -- ^ Handler to invoke if an exception is raised + -> IO a +catch = ExceptionBase.catchException + +catches :: IO a -> [Handler a] -> IO a +catches io handlers = io `catch` catchesHandler handlers + +catchesHandler :: [Handler a] -> SomeException -> IO a +catchesHandler handlers e = foldr tryHandler (throw e) handlers + where tryHandler (Handler handler) res + = case fromException e of + Just e' -> handler e' + Nothing -> res + +data Handler a = forall e . Exception e => Handler (e -> IO a) +#endif -- | The function 'catchJust' is like 'catch', but it takes an extra -- argument which is an /exception predicate/, a function which --- selects which type of exceptions we\'re interested in. There are --- some predefined exception predicates for useful subsets of --- exceptions: 'ioErrors', 'arithExceptions', and so on. For example, --- to catch just calls to the 'error' function, we could use +-- selects which type of exceptions we\'re interested in. -- -- > result <- catchJust errorCalls thing_to_try handler -- @@ -190,26 +279,30 @@ catch = ExceptionBase.catchException -- are re-raised, and may be caught by an enclosing -- 'catch' or 'catchJust'. catchJust - :: (Exception -> Maybe b) -- ^ Predicate to select exceptions - -> IO a -- ^ Computation to run - -> (b -> IO a) -- ^ Handler - -> IO a + :: Exception e + => (e -> Maybe b) -- ^ Predicate to select exceptions + -> IO a -- ^ Computation to run + -> (b -> IO a) -- ^ Handler + -> IO a catchJust p a handler = catch a handler' where handler' e = case p e of - Nothing -> throw e - Just b -> handler b + Nothing -> throw e + Just b -> handler b -- | A version of 'catch' with the arguments swapped around; useful in -- situations where the code for the handler is shorter. For example: -- -- > do handle (\e -> exitWith (ExitFailure 1)) $ --- > ... -handle :: (Exception -> IO a) -> IO a -> IO a +-- > ... +handle :: Exception e => (e -> IO a) -> IO a -> IO a handle = flip catch +handleAny :: (forall e . Exception e => e -> IO a) -> IO a -> IO a +handleAny = flip catchAny + -- | A version of 'catchJust' with the arguments swapped around (see -- 'handle'). -handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a +handleJust :: Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a handleJust p = flip (catchJust p) ----------------------------------------------------------------------------- @@ -220,7 +313,7 @@ handleJust p = flip (catchJust p) -- Notice that the usage of 'unsafePerformIO' is safe here. -mapException :: (Exception -> Exception) -> a -> a +mapException :: Exception e => (e -> e) -> a -> a mapException f v = unsafePerformIO (catch (evaluate v) (\x -> throw (f x))) @@ -231,7 +324,7 @@ mapException f v = unsafePerformIO (catch (evaluate v) -- @('Right' a)@ if no exception was raised, or @('Left' e)@ if an -- exception was raised and its value is @e@. -- --- > try a = catch (Right \`liftM\` a) (return . Left) +-- > try a = catch (Right `liftM` a) (return . Left) -- -- Note: as with 'catch', it is only polite to use this variant if you intend -- to re-throw the exception after performing whatever cleanup is needed. @@ -242,95 +335,27 @@ mapException f v = unsafePerformIO (catch (evaluate v) -- except that it catches only the IO and user families of exceptions -- (as required by the Haskell 98 @IO@ module). -try :: IO a -> IO (Either Exception a) +try :: Exception e => IO a -> IO (Either e a) try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e)) -- | A variant of 'try' that takes an exception predicate to select -- which exceptions are caught (c.f. 'catchJust'). If the exception -- does not match the predicate, it is re-thrown. -tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a) +tryJust :: Exception e => (e -> Maybe b) -> IO a -> IO (Either b a) tryJust p a = do r <- try a case r of - Right v -> return (Right v) - Left e -> case p e of - Nothing -> throw e - Just b -> return (Left b) - ------------------------------------------------------------------------------ --- Dynamic exceptions - --- $dynamic --- #DynamicExceptions# Because the 'Exception' datatype is not extensible, there is an --- interface for throwing and catching exceptions of type 'Dynamic' --- (see "Data.Dynamic") which allows exception values of any type in --- the 'Typeable' class to be thrown and caught. - --- | Raise any value as an exception, provided it is in the --- 'Typeable' class. -throwDyn :: Typeable exception => exception -> b -throwDyn exception = throw (DynException (toDyn exception)) - -#ifdef __GLASGOW_HASKELL__ --- | A variant of 'throwDyn' that throws the dynamic exception to an --- arbitrary thread (GHC only: c.f. 'throwTo'). -throwDynTo :: Typeable exception => ThreadId -> exception -> IO () -throwDynTo t exception = throwTo t (DynException (toDyn exception)) -#endif /* __GLASGOW_HASKELL__ */ - --- | Catch dynamic exceptions of the required type. All other --- exceptions are re-thrown, including dynamic exceptions of the wrong --- type. --- --- When using dynamic exceptions it is advisable to define a new --- datatype to use for your exception type, to avoid possible clashes --- with dynamic exceptions used in other libraries. --- -catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a -catchDyn m k = catchException m handle - where handle ex = case ex of - (DynException dyn) -> - case fromDynamic dyn of - Just exception -> k exception - Nothing -> throw ex - _ -> throw ex + Right v -> return (Right v) + Left e -> case p e of + Nothing -> throw e + Just b -> return (Left b) ------------------------------------------------------------------------------ --- Exception Predicates - --- $preds --- These pre-defined predicates may be used as the first argument to --- 'catchJust', 'tryJust', or 'handleJust' to select certain common --- classes of exceptions. - -ioErrors :: Exception -> Maybe IOError -arithExceptions :: Exception -> Maybe ArithException -errorCalls :: Exception -> Maybe String -assertions :: Exception -> Maybe String -dynExceptions :: Exception -> Maybe Dynamic -asyncExceptions :: Exception -> Maybe AsyncException -userErrors :: Exception -> Maybe String - -ioErrors (IOException e) = Just e -ioErrors _ = Nothing - -arithExceptions (ArithException e) = Just e -arithExceptions _ = Nothing - -errorCalls (ErrorCall e) = Just e -errorCalls _ = Nothing +ignoreExceptions :: IO () -> IO () +ignoreExceptions io = io `catchAny` \_ -> return () -assertions (AssertionFailed e) = Just e -assertions _ = Nothing - -dynExceptions (DynException e) = Just e -dynExceptions _ = Nothing - -asyncExceptions (AsyncException e) = Just e -asyncExceptions _ = Nothing - -userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e) -userErrors _ = Nothing +onException :: IO a -> IO () -> IO a +onException io what = io `catch` \e -> do what + throw (e :: SomeException) ----------------------------------------------------------------------------- -- Some Useful Functions @@ -352,36 +377,37 @@ userErrors _ = Nothing -- The arguments to 'bracket' are in this order so that we can partially apply -- it, e.g.: -- --- > withFile name = bracket (openFile name) hClose +-- > withFile name mode = bracket (openFile name mode) hClose -- +#ifndef __NHC__ bracket - :: IO a -- ^ computation to run first (\"acquire resource\") - -> (a -> IO b) -- ^ computation to run last (\"release resource\") - -> (a -> IO c) -- ^ computation to run in-between - -> IO c -- returns the value from the in-between computation + :: IO a -- ^ computation to run first (\"acquire resource\") + -> (a -> IO b) -- ^ computation to run last (\"release resource\") + -> (a -> IO c) -- ^ computation to run in-between + -> IO c -- returns the value from the in-between computation bracket before after thing = block (do a <- before - r <- catch - (unblock (thing a)) - (\e -> do { after a; throw e }) + r <- catchAny + (unblock (thing a)) + (\e -> do { after a; throw e }) after a return r ) - +#endif -- | A specialised variant of 'bracket' with just a computation to run -- afterward. -- -finally :: IO a -- ^ computation to run first - -> IO b -- ^ computation to run afterward (even if an exception - -- was raised) - -> IO a -- returns the value from the first computation +finally :: IO a -- ^ computation to run first + -> IO b -- ^ computation to run afterward (even if an exception + -- was raised) + -> IO a -- returns the value from the first computation a `finally` sequel = block (do - r <- catch - (unblock a) - (\e -> do { sequel; throw e }) + r <- catchAny + (unblock a) + (\e -> do { sequel; throw e }) sequel return r ) @@ -394,16 +420,16 @@ bracket_ before after thing = bracket before (const after) (const thing) -- | Like bracket, but only performs the final action if there was an -- exception raised by the in-between computation. bracketOnError - :: IO a -- ^ computation to run first (\"acquire resource\") - -> (a -> IO b) -- ^ computation to run last (\"release resource\") - -> (a -> IO c) -- ^ computation to run in-between - -> IO c -- returns the value from the in-between computation + :: IO a -- ^ computation to run first (\"acquire resource\") + -> (a -> IO b) -- ^ computation to run last (\"release resource\") + -> (a -> IO c) -- ^ computation to run in-between + -> IO c -- returns the value from the in-between computation bracketOnError before after thing = block (do a <- before - catch - (unblock (thing a)) - (\e -> do { after a; throw e }) + catchAny + (unblock (thing a)) + (\e -> do { after a; throw e }) ) -- ----------------------------------------------------------------------------- @@ -483,7 +509,7 @@ Similar arguments apply for other interruptible operations like 'System.IO.openFile'. -} -#ifndef __GLASGOW_HASKELL__ +#if !(__GLASGOW_HASKELL__ || __NHC__) assert :: Bool -> a -> a assert True x = x assert False _ = throw (AssertionFailed "") @@ -492,25 +518,181 @@ assert False _ = throw (AssertionFailed "") #ifdef __GLASGOW_HASKELL__ {-# NOINLINE uncaughtExceptionHandler #-} -uncaughtExceptionHandler :: IORef (Exception -> IO ()) +uncaughtExceptionHandler :: IORef (SomeException -> IO ()) uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler) where - defaultHandler :: Exception -> IO () - defaultHandler ex = do - (hFlush stdout) `catchException` (\ _ -> return ()) - let msg = case ex of - Deadlock -> "no threads to run: infinite loop or deadlock?" - ErrorCall s -> s - other -> showsPrec 0 other "\n" + defaultHandler :: SomeException -> IO () + defaultHandler se@(SomeException ex) = do + (hFlush stdout) `catchAny` (\ _ -> return ()) + let msg = case cast ex of + Just Deadlock -> "no threads to run: infinite loop or deadlock?" + _ -> case cast ex of + Just (ErrorCall s) -> s + _ -> showsPrec 0 se "" withCString "%s" $ \cfmt -> withCString msg $ \cmsg -> errorBelch cfmt cmsg -foreign import ccall unsafe errorBelch :: CString -> CString -> IO () +-- don't use errorBelch() directly, because we cannot call varargs functions +-- using the FFI. +foreign import ccall unsafe "HsBase.h errorBelch2" + errorBelch :: CString -> CString -> IO () -setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO () +setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO () setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler -getUncaughtExceptionHandler :: IO (Exception -> IO ()) +getUncaughtExceptionHandler :: IO (SomeException -> IO ()) getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler #endif + +recSelError, recConError, irrefutPatError, runtimeError, + nonExhaustiveGuardsError, patError, noMethodBindingError + :: Addr# -> a -- All take a UTF8-encoded C string + +recSelError s = throw (RecSelError (unpackCStringUtf8# s)) -- No location info unfortunately +runtimeError s = error (unpackCStringUtf8# s) -- No location info unfortunately + +nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in")) +irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern")) +recConError s = throw (RecConError (untangle s "Missing field in record construction")) +noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation")) +patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in")) + +----- + +data PatternMatchFail = PatternMatchFail String +INSTANCE_TYPEABLE0(PatternMatchFail,patternMatchFailTc,"PatternMatchFail") + +instance Exception PatternMatchFail + +instance Show PatternMatchFail where + showsPrec _ (PatternMatchFail err) = showString err + +----- + +data RecSelError = RecSelError String +INSTANCE_TYPEABLE0(RecSelError,recSelErrorTc,"RecSelError") + +instance Exception RecSelError + +instance Show RecSelError where + showsPrec _ (RecSelError err) = showString err + +----- + +data RecConError = RecConError String +INSTANCE_TYPEABLE0(RecConError,recConErrorTc,"RecConError") + +instance Exception RecConError + +instance Show RecConError where + showsPrec _ (RecConError err) = showString err + +----- + +data RecUpdError = RecUpdError String +INSTANCE_TYPEABLE0(RecUpdError,recUpdErrorTc,"RecUpdError") + +instance Exception RecUpdError + +instance Show RecUpdError where + showsPrec _ (RecUpdError err) = showString err + +----- + +data NoMethodError = NoMethodError String +INSTANCE_TYPEABLE0(NoMethodError,noMethodErrorTc,"NoMethodError") + +instance Exception NoMethodError + +instance Show NoMethodError where + showsPrec _ (NoMethodError err) = showString err + +----- + +data AssertionFailed = AssertionFailed String +INSTANCE_TYPEABLE0(AssertionFailed,assertionFailedTc,"AssertionFailed") + +instance Exception AssertionFailed + +instance Show AssertionFailed where + showsPrec _ (AssertionFailed err) = showString err + +----- + +data NonTermination = NonTermination +INSTANCE_TYPEABLE0(NonTermination,nonTerminationTc,"NonTermination") + +instance Exception NonTermination + +instance Show NonTermination where + showsPrec _ NonTermination = showString "<>" + +-- GHC's RTS calls this +nonTermination :: SomeException +nonTermination = toException NonTermination + +----- + +data Deadlock = Deadlock +INSTANCE_TYPEABLE0(Deadlock,deadlockTc,"Deadlock") + +instance Exception Deadlock + +instance Show Deadlock where + showsPrec _ Deadlock = showString "<>" + +----- + +data NestedAtomically = NestedAtomically +INSTANCE_TYPEABLE0(NestedAtomically,nestedAtomicallyTc,"NestedAtomically") + +instance Exception NestedAtomically + +instance Show NestedAtomically where + showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested" + +-- GHC's RTS calls this +nestedAtomically :: SomeException +nestedAtomically = toException NestedAtomically + +----- + +instance Exception Dynamic + +----- + +assertError :: Addr# -> Bool -> a -> a +assertError str pred v + | pred = v + | otherwise = throw (AssertionFailed (untangle str "Assertion failed")) + +{- +(untangle coded message) expects "coded" to be of the form + "location|details" +It prints + location message details +-} +untangle :: Addr# -> String -> String +untangle coded message + = location + ++ ": " + ++ message + ++ details + ++ "\n" + where + coded_str = unpackCStringUtf8# coded + + (location, details) + = case (span not_bar coded_str) of { (loc, rest) -> + case rest of + ('|':det) -> (loc, ' ' : det) + _ -> (loc, "") + } + not_bar c = c /= '|' + +-- XXX From GHC.Conc +throwTo :: Exception e => ThreadId -> e -> IO () +throwTo (ThreadId id) ex = IO $ \ s -> + case (killThread# id (toException ex) s) of s1 -> (# s1, () #) +