[project @ 2003-05-12 10:16:22 by ross]
[ghc-base.git] / Control / Exception.hs
index 5231db4..0d02dbe 100644 (file)
@@ -23,9 +23,12 @@ module Control.Exception (
        AsyncException(..),     -- instance Eq, Ord, Show, Typeable
 
        -- * Throwing exceptions
+       throwIO,        -- :: Exception -> IO a
        throw,          -- :: Exception -> a
-       ioError,        -- :: Exception -> IO a
+       ioError,        -- :: IOError -> IO a
+#ifdef __GLASGOW_HASKELL__
        throwTo,        -- :: ThreadId -> Exception -> a
+#endif
 
        -- * Catching Exceptions
 
@@ -48,6 +51,9 @@ module Control.Exception (
        -- ** The @evaluate@ function
        evaluate,  -- :: a -> IO a
 
+       -- ** The @mapException@ function
+       mapException,           -- :: (Exception -> Exception) -> a -> a
+
        -- ** Exception predicates
        
        -- $preds
@@ -64,7 +70,9 @@ module Control.Exception (
 
        -- $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
@@ -101,25 +109,19 @@ module Control.Exception (
   ) where
 
 #ifdef __GLASGOW_HASKELL__
-import Prelude                 hiding (catch)
-import System.IO.Error
 import GHC.Base                ( assert )
-import GHC.Exception   hiding (try, catch, bracket, bracket_)
+import GHC.Exception   as ExceptionBase hiding (catch)
 import GHC.Conc                ( throwTo, ThreadId )
 import GHC.IOBase      ( IO(..) )
 #endif
 
 #ifdef __HUGS__
-import Prelude hiding ( catch )
-import PrelPrim        ( catchException 
-               , Exception(..)
-               , throw
-               , ArithException(..)
-               , AsyncException(..)
-               , assert
-               )
+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
 
 #include "Dynamic.h"
@@ -156,7 +158,7 @@ INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")
 --
 -- Note that 'catch' catches all types of exceptions, and is generally
 -- used for \"cleaning up\" before passing on the exception using
--- 'ioError'.  It is not good practice to discard the exception and
+-- 'throwIO'.  It is not good practice to discard the exception and
 -- continue, without first checking the type of the exception (it
 -- might be a 'ThreadKilled', for example).  In this case it is usually better
 -- to use 'catchJust' and select the kinds of exceptions to catch.
@@ -174,7 +176,7 @@ INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")
 catch          :: IO a                 -- ^ The computation to run
        -> (Exception -> IO a)  -- ^ Handler to invoke if an exception is raised
        -> IO a                 
-catch =  GHC.Exception.catchException
+catch =  ExceptionBase.catchException
 
 -- | The function 'catchJust' is like 'catch', but it takes an extra
 -- argument which is an /exception predicate/, a function which
@@ -222,8 +224,25 @@ handleJust p =  flip (catchJust p)
 -- >   catch (evaluate undefined) (\e -> return ())  ==> return ()
 --
 -- NOTE: @(evaluate a)@ is /not/ the same as @(a \`seq\` return a)@.
+#ifdef __GLASGOW_HASKELL__
 evaluate :: a -> IO a
-evaluate a = IO $ \s -> a `seq` (# s, a #)
+evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #)
+       -- NB. can't write  
+       --      a `seq` (# s, a #)
+       -- because we can't have an unboxed tuple as a function argument
+#endif
+
+-----------------------------------------------------------------------------
+-- 'mapException'
+
+-- | This function maps one exception into another as proposed in the
+-- paper \"A semantics for imprecise exceptions\".
+
+-- Notice that the usage of 'unsafePerformIO' is safe here.
+
+mapException :: (Exception -> Exception) -> a -> a
+mapException f v = unsafePerformIO (catch (evaluate v)
+                                          (\x -> throw (f x)))
 
 -----------------------------------------------------------------------------
 -- 'try' and variations.
@@ -257,7 +276,7 @@ tryJust p a = do
 -- Dynamic exceptions
 
 -- $dynamic
--- Because the 'Exception' datatype is not extensible, there is an
+--  #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.
@@ -267,10 +286,12 @@ tryJust p a = do
 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 (c.f. 'throwTo').
+-- 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
@@ -300,12 +321,12 @@ catchDyn m k = catchException m handle
 ioErrors               :: Exception -> Maybe IOError
 arithExceptions        :: Exception -> Maybe ArithException
 errorCalls             :: Exception -> Maybe String
-dynExceptions          :: Exception -> Maybe Dynamic
 assertions             :: Exception -> Maybe String
+dynExceptions          :: Exception -> Maybe Dynamic
 asyncExceptions        :: Exception -> Maybe AsyncException
 userErrors             :: Exception -> Maybe String
 
-ioErrors e@(IOException _) = Just e
+ioErrors (IOException e) = Just e
 ioErrors _ = Nothing
 
 arithExceptions (ArithException e) = Just e
@@ -323,7 +344,7 @@ dynExceptions _ = Nothing
 asyncExceptions (AsyncException e) = Just e
 asyncExceptions _ = Nothing
 
-userErrors e | isUserError e = Just (ioeGetErrorString e)
+userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e)
 userErrors _ = Nothing
 
 -----------------------------------------------------------------------------
@@ -390,7 +411,7 @@ bracket_ before after thing = bracket before (const after) (const thing)
 
 {- $async
 
-Asynchronous exceptions are so-called because they arise due to
+ #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to
 external influences, and can be raised at any point during execution.
 'StackOverflow' and 'HeapOverflow' are two examples of
 system-generated asynchronous exceptions.
@@ -475,3 +496,9 @@ Similar arguments apply for other interruptible operations like
 -- returned as the result.
 assert :: Bool -> a -> a
 #endif
+
+#ifndef __GLASGOW_HASKELL__
+assert :: Bool -> a -> a
+assert True x = x
+assert False _ = throw (AssertionFailed "")
+#endif