X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FException%2FBase.hs;h=a6179178de990de32f4874caac9a342bb160dc5f;hb=509f28cc93b980d30aca37008cbe66c677a0d6f6;hp=f32b2f72e14bd07b81f97af0fbd2607ed96c9e97;hpb=d2063b5b0be014545b21819172c87756efcb0b0c;p=ghc-base.git diff --git a/Control/Exception/Base.hs b/Control/Exception/Base.hs index f32b2f7..a617917 100644 --- a/Control/Exception/Base.hs +++ b/Control/Exception/Base.hs @@ -1,5 +1,7 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif #include "Typeable.h" @@ -37,8 +39,8 @@ module Control.Exception.Base ( NestedAtomically(..), #endif - BlockedOnDeadMVar(..), - BlockedIndefinitely(..), + BlockedIndefinitelyOnMVar(..), + BlockedIndefinitelyOnSTM(..), Deadlock(..), NoMethodError(..), PatternMatchFail(..), @@ -79,6 +81,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,18 +112,19 @@ module Control.Exception.Base ( -- * Calls for GHC runtime recSelError, recConError, irrefutPatError, runtimeError, nonExhaustiveGuardsError, patError, noMethodBindingError, + absentError, nonTermination, nestedAtomically, #endif ) where #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IO hiding (finally,onException) +import GHC.IO hiding (bracket,finally,onException) import GHC.IO.Exception import GHC.Exception import GHC.Show -import GHC.Exception hiding ( Exception ) -import GHC.Conc +-- import GHC.Exception hiding ( Exception ) +import GHC.Conc.Sync #endif #ifdef __HUGS__ @@ -176,8 +189,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 +202,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 +228,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 +251,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 +289,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 +300,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 +357,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'. @@ -412,7 +429,7 @@ catchJust -> IO a catchJust p a handler = catch a handler' where handler' e = case p e of - Nothing -> throw e + Nothing -> throwIO e Just b -> handler b -- | A version of 'catch' with the arguments swapped around; useful in @@ -438,7 +455,7 @@ handleJust p = flip (catchJust p) mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a mapException f v = unsafePerformIO (catch (evaluate v) - (\x -> throw (f x))) + (\x -> throwIO (f x))) ----------------------------------------------------------------------------- -- 'try' and variations. @@ -468,14 +485,14 @@ tryJust p a = do case r of Right v -> return (Right v) Left e -> case p e of - Nothing -> throw e + Nothing -> throwIO e Just b -> return (Left b) -- | Like 'finally', but only performs the final action if there was an -- exception raised by the computation. onException :: IO a -> IO b -> IO a -onException io what = io `catch` \e -> do what - throw (e :: SomeException) +onException io what = io `catch` \e -> do _ <- what + throwIO (e :: SomeException) ----------------------------------------------------------------------------- -- Some Useful Functions @@ -506,12 +523,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 - 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 +538,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 - 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 +556,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 @@ -691,18 +705,18 @@ instance Exception NestedAtomically ----- -instance Exception Dynamic - #endif /* __GLASGOW_HASKELL__ || __HUGS__ */ #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"))