X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FException%2FBase.hs;h=cb5321b76b1524313eedceef2bbb25e903d0c1cc;hb=41e8fba828acbae1751628af50849f5352b27873;hp=b6893fb2d9b044794e51a53776dbc164bcceb4e6;hpb=c1f3c4852894174a3f7b855b29e8a42f60d4c019;p=ghc-base.git diff --git a/Control/Exception/Base.hs b/Control/Exception/Base.hs index b6893fb..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__ @@ -128,9 +139,8 @@ import Data.Either import Data.Maybe #ifdef __NHC__ -import qualified System.IO.Error as H'98 (catch) -import System.IO.Error (ioError) -import IO (bracket) +import qualified IO as H'98 (catch) +import IO (bracket,ioError) import DIOError -- defn of IOError type import System (ExitCode()) import System.IO.Unsafe (unsafePerformIO) @@ -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" @@ -333,31 +347,35 @@ blocked = return False -- the \"handler\" is executed, with the value of the exception passed as an -- argument. Otherwise, the result is returned as normal. For example: -- --- > catch (openFile f ReadMode) --- > (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e)) +-- > catch (readFile f) +-- > (\e -> do let err = show (e :: IOException) +-- > hPutStr stderr ("Warning: Couldn't open " ++ f ++ ": " ++ err) +-- > return "") +-- +-- 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 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'. -- -- Note that due to Haskell\'s unspecified evaluation order, an --- expression may return one of several possible exceptions: consider --- the expression @error \"urk\" + 1 \`div\` 0@. Does --- 'catch' execute the handler passing --- @ErrorCall \"urk\"@, or @ArithError DivideByZero@? --- --- The answer is \"either\": 'catch' makes a --- non-deterministic choice about which exception to catch. If you --- call it again, you might get a different exception back. This is --- ok, because 'catch' is an 'IO' computation. +-- expression may throw one of several possible exceptions: consider +-- the expression @(error \"urk\") + (1 \`div\` 0)@. Does +-- the expression throw +-- @ErrorCall \"urk\"@, or @DivideByZero@? -- --- Note that 'catch' catches all types of exceptions, and is generally --- used for \"cleaning up\" before passing on the exception using --- '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. +-- The answer is \"it might throw either\"; the choice is +-- non-deterministic. If you are catching any type of exception then you +-- might catch either. If you are calling @catch@ with type +-- @IO Int -> (ArithException -> IO Int) -> IO Int@ then the handler may +-- get run with @DivideByZero@ as an argument, or an @ErrorCall \"urk\"@ +-- exception may be propogated further up. If you call it again, you +-- might get a the opposite behaviour. This is ok, because 'catch' is an +-- 'IO' computation. -- --- Also note that the "Prelude" also exports a function called +-- Note that the "Prelude" also exports a function called -- 'Prelude.catch' with a similar type to 'Control.Exception.catch', -- except that the "Prelude" version only catches the IO and user -- families of exceptions (as required by Haskell 98). @@ -379,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 @@ -392,11 +410,14 @@ catch m h = Hugs.Exception.catchException m h' -- argument which is an /exception predicate/, a function which -- selects which type of exceptions we\'re interested in. -- --- > result <- catchJust errorCalls thing_to_try handler +-- > catchJust (\e -> if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing) +-- > (readFile f) +-- > (\_ -> do hPutStrLn stderr ("No such file: " ++ show f) +-- > return "") -- -- Any other exceptions which are not matched by the predicate -- are re-raised, and may be caught by an enclosing --- 'catch' or 'catchJust'. +-- 'catch', 'catchJust', etc. catchJust :: Exception e => (e -> Maybe b) -- ^ Predicate to select exceptions @@ -405,13 +426,13 @@ 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 -- situations where the code for the handler is shorter. For example: -- --- > do handle (\e -> exitWith (ExitFailure 1)) $ +-- > do handle (\NonTermination -> exitWith (ExitFailure 1)) $ -- > ... handle :: Exception e => (e -> IO a) -> IO a -> IO a handle = flip catch @@ -431,22 +452,20 @@ 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. -- | Similar to 'catch', but returns an 'Either' result which is --- @('Right' a)@ if no exception was raised, or @('Left' e)@ if an --- exception was raised and its value is @e@. +-- @('Right' a)@ if no exception of type @e@ was raised, or @('Left' ex)@ +-- if an exception of type @e@ was raised and its value is @ex@. +-- If any other type of exception is raised than it will be propogated +-- up to the next enclosing exception handler. -- -- > try a = catch (Right `liftM` a) (return . Left) -- --- Note: as with 'catch', it is only polite to use this variant if you intend --- to re-throw the exception after performing whatever cleanup is needed. --- Otherwise, 'tryJust' is generally considered to be better. --- --- Also note that "System.IO.Error" also exports a function called +-- Note that "System.IO.Error" also exports a function called -- 'System.IO.Error.try' with a similar type to 'Control.Exception.try', -- except that it catches only the IO and user families of exceptions -- (as required by the Haskell 98 @IO@ module). @@ -463,12 +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 @@ -485,7 +506,7 @@ onException io what = io `catch` \e -> do what -- > bracket -- > (openFile "filename" ReadMode) -- > (hClose) --- > (\handle -> do { ... }) +-- > (\fileHandle -> do { ... }) -- -- The arguments to 'bracket' are in this order so that we can partially apply -- it, e.g.: @@ -499,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 @@ -515,18 +535,17 @@ 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. bracket_ :: IO a -> IO b -> IO c -> IO c bracket_ before after thing = bracket before (const after) (const thing) --- | Like bracket, but only performs the final action if there was an +-- | Like 'bracket', but only performs the final action if there was an -- exception raised by the in-between computation. bracketOnError :: IO a -- ^ computation to run first (\"acquire resource\") @@ -534,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 @@ -548,6 +566,8 @@ assert False _ = throw (AssertionFailed "") ----- #if __GLASGOW_HASKELL__ || __HUGS__ +-- |A pattern match failed. The @String@ gives information about the +-- source location of the pattern. data PatternMatchFail = PatternMatchFail String INSTANCE_TYPEABLE0(PatternMatchFail,patternMatchFailTc,"PatternMatchFail") @@ -565,6 +585,11 @@ instance Exception PatternMatchFail ----- +-- |A record selector was applied to a constructor without the +-- appropriate field. This can only happen with a datatype with +-- multiple constructors, where some fields are in one constructor +-- but not another. The @String@ gives information about the source +-- location of the record selector. data RecSelError = RecSelError String INSTANCE_TYPEABLE0(RecSelError,recSelErrorTc,"RecSelError") @@ -582,6 +607,9 @@ instance Exception RecSelError ----- +-- |An uninitialised record field was used. The @String@ gives +-- information about the source location where the record was +-- constructed. data RecConError = RecConError String INSTANCE_TYPEABLE0(RecConError,recConErrorTc,"RecConError") @@ -599,6 +627,11 @@ instance Exception RecConError ----- +-- |A record update was performed on a constructor without the +-- appropriate field. This can only happen with a datatype with +-- multiple constructors, where some fields are in one constructor +-- but not another. The @String@ gives information about the source +-- location of the record update. data RecUpdError = RecUpdError String INSTANCE_TYPEABLE0(RecUpdError,recUpdErrorTc,"RecUpdError") @@ -616,6 +649,9 @@ instance Exception RecUpdError ----- +-- |A class method without a definition (neither a default definition, +-- nor a definition in the appropriate instance) was called. The +-- @String@ gives information about which method it was. data NoMethodError = NoMethodError String INSTANCE_TYPEABLE0(NoMethodError,noMethodErrorTc,"NoMethodError") @@ -633,6 +669,10 @@ instance Exception NoMethodError ----- +-- |Thrown when the runtime system detects that the computation is +-- guaranteed not to terminate. Note that there is no guarantee that +-- the runtime system will notice whether any given computation is +-- guaranteed to terminate or not. data NonTermination = NonTermination INSTANCE_TYPEABLE0(NonTermination,nonTerminationTc,"NonTermination") @@ -650,6 +690,8 @@ instance Exception NonTermination ----- +-- |Thrown when the program attempts to call @atomically@, from the @stm@ +-- package, inside another call to @atomically@. data NestedAtomically = NestedAtomically INSTANCE_TYPEABLE0(NestedAtomically,nestedAtomicallyTc,"NestedAtomically") @@ -660,17 +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 (unpackCStringUtf8# s)) -- No location info unfortunately -runtimeError s = error (unpackCStringUtf8# s) -- No location info unfortunately +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"))