X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FException%2FBase.hs;h=8ea4bf4bda531425dd051b8eac287636385259ae;hb=f5876f9fc3651f757556ca9c78ade3e253639b33;hp=4b314ede3f1dd30a741a657b32693892385f2036;hpb=c2bb8f57dae0c99576de544b953e0322d0b9af05;p=ghc-base.git

diff --git a/Control/Exception/Base.hs b/Control/Exception/Base.hs
index 4b314ed..8ea4bf4 100644
--- a/Control/Exception/Base.hs
+++ b/Control/Exception/Base.hs
@@ -1,5 +1,4 @@
 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 #include "Typeable.h"
 
@@ -37,8 +36,8 @@ module Control.Exception.Base (
         NestedAtomically(..),
 #endif
 
-        BlockedOnDeadMVar(..),
-        BlockedIndefinitely(..),
+        BlockedIndefinitelyOnMVar(..),
+        BlockedIndefinitelyOnSTM(..),
         Deadlock(..),
         NoMethodError(..),
         PatternMatchFail(..),
@@ -79,6 +78,16 @@ module Control.Exception.Base (
         -- * Asynchronous Exceptions
 
         -- ** Asynchronous exception control
+        mask,
+#ifndef __NHC__
+        mask_,
+        uninterruptibleMask,
+        uninterruptibleMask_,
+        MaskingState(..),
+        getMaskingState,
+#endif
+
+        -- ** (deprecated) Asynchronous exception control
 
         block,
         unblock,
@@ -100,6 +109,7 @@ module Control.Exception.Base (
         -- * Calls for GHC runtime
         recSelError, recConError, irrefutPatError, runtimeError,
         nonExhaustiveGuardsError, patError, noMethodBindingError,
+        absentError,
         nonTermination, nestedAtomically,
 #endif
   ) where
@@ -111,7 +121,7 @@ import GHC.IO.Exception
 import GHC.Exception
 import GHC.Show
 -- import GHC.Exception hiding ( Exception )
-import GHC.Conc
+import GHC.Conc.Sync
 #endif
 
 #ifdef __HUGS__
@@ -176,8 +186,8 @@ data AssertionFailed
 data PatternMatchFail
 data NoMethodError
 data Deadlock
-data BlockedOnDeadMVar
-data BlockedIndefinitely
+data BlockedIndefinitelyOnMVar
+data BlockedIndefinitelyOnSTM
 data ErrorCall
 data RecConError
 data RecSelError
@@ -189,8 +199,8 @@ instance Show AssertionFailed
 instance Show PatternMatchFail
 instance Show NoMethodError
 instance Show Deadlock
-instance Show BlockedOnDeadMVar
-instance Show BlockedIndefinitely
+instance Show BlockedIndefinitelyOnMVar
+instance Show BlockedIndefinitelyOnSTM
 instance Show ErrorCall
 instance Show RecConError
 instance Show RecSelError
@@ -215,6 +225,10 @@ assert :: Bool -> a -> a
 assert True  x = x
 assert False _ = throw (toException (UserError "" "Assertion failed"))
 
+mask   :: ((IO a-> IO a) -> IO a) -> IO a
+mask action = action restore
+    where restore act = act
+
 #endif
 
 #ifdef __HUGS__
@@ -234,8 +248,8 @@ INSTANCE_TYPEABLE0(ExitCode,exitCodeTc,"ExitCode")
 INSTANCE_TYPEABLE0(ErrorCall,errorCallTc,"ErrorCall")
 INSTANCE_TYPEABLE0(AssertionFailed,assertionFailedTc,"AssertionFailed")
 INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")
-INSTANCE_TYPEABLE0(BlockedOnDeadMVar,blockedOnDeadMVarTc,"BlockedOnDeadMVar")
-INSTANCE_TYPEABLE0(BlockedIndefinitely,blockedIndefinitelyTc,"BlockedIndefinitely")
+INSTANCE_TYPEABLE0(BlockedIndefinitelyOnMVar,blockedIndefinitelyOnMVarTc,"BlockedIndefinitelyOnMVar")
+INSTANCE_TYPEABLE0(BlockedIndefinitelyOnSTM,blockedIndefinitelyOnSTM,"BlockedIndefinitelyOnSTM")
 INSTANCE_TYPEABLE0(Deadlock,deadlockTc,"Deadlock")
 
 instance Exception SomeException where
@@ -272,8 +286,8 @@ instance Exception ErrorCall where
     fromException (Hugs.Exception.ErrorCall s) = Just (ErrorCall s)
     fromException _ = Nothing
 
-data BlockedOnDeadMVar = BlockedOnDeadMVar
-data BlockedIndefinitely = BlockedIndefinitely
+data BlockedIndefinitelyOnMVar = BlockedIndefinitelyOnMVar
+data BlockedIndefinitelyOnSTM = BlockedIndefinitelyOnSTM
 data Deadlock = Deadlock
 data AssertionFailed = AssertionFailed String
 data AsyncException
@@ -283,8 +297,8 @@ data AsyncException
   | UserInterrupt
   deriving (Eq, Ord)
 
-instance Show BlockedOnDeadMVar where
-    showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"
+instance Show BlockedIndefinitelyOnMVar where
+    showsPrec _ BlockedIndefinitelyOnMVar = showString "thread blocked indefinitely"
 
 instance Show BlockedIndefinitely where
     showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"
@@ -340,8 +354,8 @@ blocked  = return False
 --
 -- Note that we have to give a type signature to @e@, or the program
 -- will not typecheck as the type is ambiguous. While it is possible
--- to catch exceptions of any type, see $catchall for an explanation
--- of the problems with doing so.
+-- to catch exceptions of any type, see the previous section \"Catching all
+-- exceptions\" for an explanation of the problems with doing so.
 --
 -- For catching exceptions in pure (non-'IO') expressions, see the
 -- function 'evaluate'.
@@ -506,12 +520,11 @@ bracket
         -> (a -> IO c)  -- ^ computation to run in-between
         -> IO c         -- returns the value from the in-between computation
 bracket before after thing =
-  block (do
+  mask $ \restore -> do
     a <- before
-    r <- unblock (thing a) `onException` after a
+    r <- restore (thing a) `onException` after a
     _ <- after a
     return r
- )
 #endif
 
 -- | A specialised variant of 'bracket' with just a computation to run
@@ -522,11 +535,10 @@ finally :: IO a         -- ^ computation to run first
                         -- was raised)
         -> IO a         -- returns the value from the first computation
 a `finally` sequel =
-  block (do
-    r <- unblock a `onException` sequel
+  mask $ \restore -> do
+    r <- restore a `onException` sequel
     _ <- sequel
     return r
-  )
 
 -- | A variant of 'bracket' where the return value from the first computation
 -- is not required.
@@ -541,10 +553,9 @@ bracketOnError
         -> (a -> IO c)  -- ^ computation to run in-between
         -> IO c         -- returns the value from the in-between computation
 bracketOnError before after thing =
-  block (do
+  mask $ \restore -> do
     a <- before
-    unblock (thing a) `onException` after a
-  )
+    restore (thing a) `onException` after a
 
 #if !(__GLASGOW_HASKELL__ || __NHC__)
 assert :: Bool -> a -> a
@@ -695,12 +706,14 @@ instance Exception NestedAtomically
 
 #ifdef __GLASGOW_HASKELL__
 recSelError, recConError, irrefutPatError, runtimeError,
-             nonExhaustiveGuardsError, patError, noMethodBindingError
+  nonExhaustiveGuardsError, patError, noMethodBindingError,
+  absentError
         :: Addr# -> a   -- All take a UTF8-encoded C string
 
 recSelError              s = throw (RecSelError ("No match in record selector "
 			                         ++ unpackCStringUtf8# s))  -- No location info unfortunately
 runtimeError             s = error (unpackCStringUtf8# s)                   -- No location info unfortunately
+absentError              s = error ("Oops!  Entered absent arg " ++ unpackCStringUtf8# s)
 
 nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
 irrefutPatError          s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))