-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
#include "Typeable.h"
NestedAtomically(..),
#endif
- BlockedOnDeadMVar(..),
- BlockedIndefinitely(..),
+ BlockedIndefinitelyOnMVar(..),
+ BlockedIndefinitelyOnSTM(..),
Deadlock(..),
NoMethodError(..),
PatternMatchFail(..),
-- * Asynchronous Exceptions
-- ** Asynchronous exception control
+ mask,
+#ifndef __NHC__
+ mask_,
+ uninterruptibleMask,
+ uninterruptibleMask_,
+ MaskingState(..),
+ getMaskingState,
+#endif
+
+ -- ** (deprecated) Asynchronous exception control
block,
unblock,
-- * 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__
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)
data PatternMatchFail
data NoMethodError
data Deadlock
-data BlockedOnDeadMVar
-data BlockedIndefinitely
+data BlockedIndefinitelyOnMVar
+data BlockedIndefinitelyOnSTM
data ErrorCall
data RecConError
data RecSelError
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
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__
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
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
| 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"
-- 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).
-> (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
-- 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
-> 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
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).
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
-- > 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.:
-> (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
-- 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\")
-> (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
-----
#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")
-----
+-- |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")
-----
+-- |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")
-----
+-- |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")
-----
+-- |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")
-----
+-- |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")
-----
+-- |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")
-----
-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"))
projects / ghc-base.git / blobdiff