X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FException.hs;h=0d02dbe24e6d8620df9d1fbc1522fd4babd6f373;hb=75ea0fa2485c169f0546d5d40477d2f6747efe29;hp=3ab3ceb264f63ae5153a4267ac50dc109cb6557a;hpb=6cd697634d66ace85702b3b9e14ddf9affd07fa2;p=ghc-base.git

diff --git a/Control/Exception.hs b/Control/Exception.hs
index 3ab3ceb..0d02dbe 100644
--- a/Control/Exception.hs
+++ b/Control/Exception.hs
@@ -17,19 +17,16 @@ module Control.Exception (
 
 	-- * The Exception type
 	Exception(..),		-- instance Eq, Ord, Show, Typeable
-#ifdef __GLASGOW_HASKELL__
 	IOException,		-- instance Eq, Ord, Show, Typeable
 	ArithException(..),	-- instance Eq, Ord, Show, Typeable
 	ArrayException(..),	-- instance Eq, Ord, Show, Typeable
 	AsyncException(..),	-- instance Eq, Ord, Show, Typeable
-#endif
 
 	-- * Throwing exceptions
-#ifndef __HUGS__
+	throwIO,	-- :: Exception -> IO a
 	throw,		-- :: Exception -> a
-#endif
-	ioError,	-- :: Exception -> IO a
-#ifndef __HUGS__
+	ioError,	-- :: IOError -> IO a
+#ifdef __GLASGOW_HASKELL__
 	throwTo,	-- :: ThreadId -> Exception -> a
 #endif
 
@@ -54,28 +51,29 @@ module Control.Exception (
 	-- ** The @evaluate@ function
 	evaluate,  -- :: a -> IO a
 
+	-- ** The @mapException@ function
+	mapException,		-- :: (Exception -> Exception) -> a -> a
+
 	-- ** Exception predicates
 	
 	-- $preds
 
 	ioErrors,		-- :: Exception -> Maybe IOError
-#ifndef __HUGS__
 	arithExceptions, 	-- :: Exception -> Maybe ArithException
 	errorCalls,		-- :: Exception -> Maybe String
 	dynExceptions,		-- :: Exception -> Maybe Dynamic
 	assertions,		-- :: Exception -> Maybe String
 	asyncExceptions, 	-- :: Exception -> Maybe AsyncException
-#endif /* __HUGS__ */
 	userErrors,		-- :: Exception -> Maybe String
 
-#ifdef __GLASGOW_HASKELL__
 	-- * Dynamic exceptions
 
 	-- $dynamic
 	throwDyn, 	-- :: Typeable ex => ex -> b
+#ifdef __GLASGOW_HASKELL__
 	throwDynTo, 	-- :: Typeable ex => ThreadId -> ex -> b
-	catchDyn, 	-- :: Typeable ex => IO a -> (ex -> IO a) -> IO a
 #endif
+	catchDyn, 	-- :: Typeable ex => IO a -> (ex -> IO a) -> IO a
 	
 	-- * Asynchronous Exceptions
 
@@ -111,36 +109,27 @@ module Control.Exception (
   ) where
 
 #ifdef __GLASGOW_HASKELL__
-import Prelude 		hiding (catch)
 import GHC.Base		( assert )
-import GHC.Exception 	as ExceptionBase 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, ioError )
-import Hugs.Exception	hiding ( evaluate )
-import qualified Hugs.Exception as ExceptionBase
+import Hugs.Exception	as ExceptionBase
 #endif
 
-import System.IO.Error
+import Prelude 		hiding ( catch )
+import System.IO.Error	hiding ( catch, try )
+import System.IO.Unsafe (unsafePerformIO)
 import Data.Dynamic
 
 #include "Dynamic.h"
 INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
-#ifdef __GLASGOW_HASKELL__
 INSTANCE_TYPEABLE0(IOException,ioExceptionTc,"IOException")
 INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")
 INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException")
 INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")
-#endif
-
-#ifdef __HUGS__
--- This is as close as Hugs gets to providing throw
-throw :: Exception -> IO a
-throw = ioError
-#endif
 
 -----------------------------------------------------------------------------
 -- Catching exceptions
@@ -169,7 +158,7 @@ throw = ioError
 --
 -- 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.
@@ -235,17 +224,27 @@ 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
-#if defined(__GLASGOW_HASKELL__)
 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
-#elif defined(__HUGS__)
-evaluate = ExceptionBase.evaluate
 #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.
 
 -- | Similar to 'catch', but returns an 'Either' result which is
@@ -273,7 +272,6 @@ tryJust p a = do
 			Nothing -> throw e
 			Just b  -> return (Left b)
 
-#ifdef __GLASGOW_HASKELL__
 -----------------------------------------------------------------------------
 -- Dynamic exceptions
 
@@ -288,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
@@ -309,7 +309,6 @@ catchDyn m k = catchException m handle
 				    Just exception  -> k exception
 				    Nothing -> throw ex
 			   _ -> throw ex
-#endif /* __GLASGOW_HASKELL__ */
 
 -----------------------------------------------------------------------------
 -- Exception Predicates
@@ -320,22 +319,14 @@ catchDyn m k = catchException m handle
 -- classes of exceptions.
 
 ioErrors		:: Exception -> Maybe IOError
-#ifdef __GLASGOW_HASKELL__
 arithExceptions 	:: Exception -> Maybe ArithException
 errorCalls		:: Exception -> Maybe String
-dynExceptions		:: Exception -> Maybe Dynamic
 assertions		:: Exception -> Maybe String
+dynExceptions		:: Exception -> Maybe Dynamic
 asyncExceptions 	:: Exception -> Maybe AsyncException
-#endif /* __GLASGOW_HASKELL__ */
 userErrors		:: Exception -> Maybe String
 
-#ifdef __HUGS__
-ioErrors = justIoErrors
-userErrors = justUserErrors
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-ioErrors e@(IOException _) = Just e
+ioErrors (IOException e) = Just e
 ioErrors _ = Nothing
 
 arithExceptions (ArithException e) = Just e
@@ -353,9 +344,8 @@ dynExceptions _ = Nothing
 asyncExceptions (AsyncException e) = Just e
 asyncExceptions _ = Nothing
 
-userErrors e@IOException{} | isUserError e = Just (ioeGetErrorString e)
+userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e)
 userErrors _ = Nothing
-#endif /* __GLASGOW_HASKELL__ */
 
 -----------------------------------------------------------------------------
 -- Some Useful Functions
@@ -510,5 +500,5 @@ assert :: Bool -> a -> a
 #ifndef __GLASGOW_HASKELL__
 assert :: Bool -> a -> a
 assert True x = x
-assert False _ = error "Assertion failure"
+assert False _ = throw (AssertionFailed "")
 #endif