X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FException%2FBase.hs;h=cb5321b76b1524313eedceef2bbb25e903d0c1cc;hb=41e8fba828acbae1751628af50849f5352b27873;hp=b803b5eaaba56cd0ddacb77a7794cc8afe1b461a;hpb=c856e1e71c608e8c291218f66645eb748270b6d2;p=ghc-base.git diff --git a/Control/Exception/Base.hs b/Control/Exception/Base.hs index b803b5e..cb5321b 100644 --- a/Control/Exception/Base.hs +++ b/Control/Exception/Base.hs @@ -1,5 +1,4 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} #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,17 +109,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.IOBase +import GHC.IO hiding (finally,onException) +import GHC.IO.Exception +import GHC.Exception import GHC.Show -import GHC.IOBase -import GHC.Exception hiding ( Exception ) -import GHC.Conc +-- import GHC.Exception hiding ( Exception ) +import GHC.Conc.Sync #endif #ifdef __HUGS__ @@ -175,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 @@ -188,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 @@ -214,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__ @@ -233,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 @@ -271,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 @@ -282,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" @@ -339,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'. @@ -382,7 +397,7 @@ catch :: Exception e -> (e -> IO a) -- ^ Handler to invoke if an exception is raised -> IO a #if __GLASGOW_HASKELL__ -catch = GHC.IOBase.catchException +catch = GHC.IO.catchException #elif __HUGS__ catch m h = Hugs.Exception.catchException m h' where h' e = case fromException e of @@ -411,7 +426,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 @@ -437,7 +452,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. @@ -467,14 +482,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 @@ -505,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 - 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 @@ -521,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 - 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. @@ -540,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 @@ -690,18 +702,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"))