X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FException.hs;h=fa067b0859a3ea6449997e78c4d1b899c7d0d361;hp=8d5d4389b6ca525c4b5e4f5d0b375d88d6aec735;hb=c0687066474aa4ce4912f31a5c09c1bcd673fb06;hpb=4767e535d9761920a18629a4142d3a929503b936

diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs
index 8d5d438..fa067b0 100644
--- a/compiler/utils/Exception.hs
+++ b/compiler/utils/Exception.hs
@@ -1,4 +1,4 @@
-
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
 module Exception
     (
     module Control.Exception,
@@ -7,56 +7,37 @@ module Exception
     where
 
 import Prelude hiding (catch)
-import Control.Exception
-
-#if __GLASGOW_HASKELL__ < 609
-import Data.Typeable ( Typeable )
-
-type SomeException = Exception
 
-onException :: IO a -> IO () -> IO a
-onException io what = io `catch` \e -> do what
-                                          throw e
-#endif
+import Control.Exception
 
 catchIO :: IO a -> (IOException -> IO a) -> IO a
-#if __GLASGOW_HASKELL__ >= 609
 catchIO = catch
-#else
-catchIO io handler = io `catch` handler'
-    where handler' (IOException ioe) = handler ioe
-          handler' e                 = throw e
-#endif
 
 handleIO :: (IOException -> IO a) -> IO a -> IO a
 handleIO = flip catchIO
 
 tryIO :: IO a -> IO (Either IOException a)
-#if __GLASGOW_HASKELL__ >= 609
 tryIO = try
-#else
-tryIO io = do ei <- try io
-              case ei of
-                  Right v -> return (Right v)
-                  Left (IOException ioe) -> return (Left ioe)
-                  Left e -> throwIO e
-#endif
 
 -- | A monad that can catch exceptions.  A minimal definition
 -- requires a definition of 'gcatch'.
 --
--- Although, 'gbracket' and 'gfinally' could be modelled on top of 'gcatch',
--- they are included in the type class since GHC needs special implementations
--- of these in order to properly handle asynchronous exceptions.
+-- Implementations on top of 'IO' should implement 'gblock' and 'gunblock' to
+-- eventually call the primitives 'Control.Exception.block' and
+-- 'Control.Exception.unblock' respectively.  These are used for
+-- implementations that support asynchronous exceptions.  The default
+-- implementations of 'gbracket' and 'gfinally' use 'gblock' and 'gunblock'
+-- thus rarely require overriding.
+--
 class Monad m => ExceptionMonad m where
+
   -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary
   -- exception handling monad instead of just 'IO'.
-#if __GLASGOW_HASKELL__ >= 609
   gcatch :: Exception e => m a -> (e -> m a) -> m a
-#else
-  gcatch :: m a -> (Exception -> m a) -> m a
-  gcatchDyn :: Typeable e => m a -> (e -> m a) -> m a
-#endif
+
+  -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary
+  -- exception handling monad instead of just 'IO'.
+  gmask :: ((m a -> m a) -> m b) -> m b
 
   -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary
   -- exception handling monad instead of just 'IO'.
@@ -66,50 +47,60 @@ class Monad m => ExceptionMonad m where
   -- exception handling monad instead of just 'IO'.
   gfinally :: m a -> m b -> m a
 
-  gbracket acquire release in_between = do
-      a <- acquire
-      r <- in_between a `gonException` release a
-      release a
+  -- | DEPRECATED, here for backwards compatibilty.  Instances can
+  -- define either 'gmask', or both 'block' and 'unblock'.
+  gblock   :: m a -> m a
+  -- | DEPRECATED, here for backwards compatibilty  Instances can
+  -- define either 'gmask', or both 'block' and 'unblock'.
+  gunblock :: m a -> m a
+  -- XXX we're keeping these two methods for the time being because we
+  -- have to interact with Haskeline's MonadException class which
+  -- still has block/unblock; see GhciMonad.hs.
+
+  gmask    f = gblock (f gunblock)
+  gblock   f = gmask (\_ -> f)
+  gunblock f = f -- XXX wrong; better override this if you need it
+
+  gbracket before after thing =
+    gmask $ \restore -> do
+      a <- before
+      r <- restore (thing a) `gonException` after a
+      _ <- after a
       return r
 
-  gfinally thing cleanup = do
-      r <- thing `gonException` cleanup
-      cleanup
+  a `gfinally` sequel =
+    gmask $ \restore -> do
+      r <- restore a `gonException` sequel
+      _ <- sequel
       return r
 
+#if __GLASGOW_HASKELL__ < 613
 instance ExceptionMonad IO where
   gcatch    = catch
-#if __GLASGOW_HASKELL__ < 609
-  gcatchDyn = catchDyn
+  gmask f   = block $ f unblock
+  gblock    = block
+  gunblock  = unblock
+#else
+instance ExceptionMonad IO where
+  gcatch    = catch
+  gmask f   = mask (\x -> f x)
+  gblock    = block
+  gunblock  = unblock
 #endif
-  gbracket  = bracket
-  gfinally  = finally
-
 
-#if __GLASGOW_HASKELL__ >= 609
 gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a)
-#else
-gtry :: (ExceptionMonad m) => m a -> m (Either Exception a)
-#endif
 gtry act = gcatch (act >>= \a -> return (Right a))
                   (\e -> return (Left e))
 
 -- | Generalised version of 'Control.Exception.handle', allowing an arbitrary
 -- exception handling monad instead of just 'IO'.
-#if __GLASGOW_HASKELL__ >= 609
 ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a
-#else
-ghandle :: (ExceptionMonad m) => (Exception -> m a) -> m a -> m a
-#endif
 ghandle = flip gcatch
 
 -- | Always executes the first argument.  If this throws an exception the
 -- second argument is executed and the exception is raised again.
 gonException :: (ExceptionMonad m) => m a -> m b -> m a
 gonException ioA cleanup = ioA `gcatch` \e ->
-                             do cleanup
-#if __GLASGOW_HASKELL__ >= 609
+                             do _ <- cleanup
                                 throw (e :: SomeException)
-#else
-                                throw e
-#endif
+