stackOverflow, heapOverflow, ioException,
IOError, IOException(..), IOErrorType(..), ioError, userError,
ExitCode(..),
- throwIO, block, unblock, catch, catchAny, catchException,
+ throwIO, block, unblock, blocked, catchAny, catchException,
evaluate,
- -- The RTS calls this
- nonTermination,
+ ErrorCall(..), AssertionFailed(..), assertError, untangle,
+ BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..)
) where
import GHC.ST
import GHC.List
import GHC.Read
import Foreign.C.Types (CInt)
-import GHC.Exception hiding (Exception)
-import qualified GHC.Exception as Exc
+import GHC.Exception
#ifndef __HADDOCK__
-import {-# SOURCE #-} Data.Typeable ( showsTypeRep )
-import {-# SOURCE #-} Data.Dynamic ( Dynamic, dynTypeRep )
+import {-# SOURCE #-} Data.Typeable ( Typeable )
+import {-# SOURCE #-} Data.Dynamic ( Dynamic )
#endif
-- ---------------------------------------------------------------------------
thenIO :: IO a -> IO b -> IO b
thenIO (IO m) k = IO ( \ s ->
case m s of
- (# new_s, a #) -> unIO k new_s
+ (# new_s, _ #) -> unIO k new_s
)
returnIO :: a -> IO a
| AppendHandle
| ReadWriteHandle
+isReadableHandleType :: HandleType -> Bool
isReadableHandleType ReadHandle = True
isReadableHandleType ReadWriteHandle = True
isReadableHandleType _ = False
+isWritableHandleType :: HandleType -> Bool
isWritableHandleType AppendHandle = True
isWritableHandleType WriteHandle = True
isWritableHandleType ReadWriteHandle = True
isWritableHandleType _ = False
+isReadWriteHandleType :: HandleType -> Bool
isReadWriteHandleType ReadWriteHandle{} = True
isReadWriteHandleType _ = False
-- |Build a new 'IOArray'
newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e)
{-# INLINE newIOArray #-}
-newIOArray lu init = stToIO $ do {marr <- newSTArray lu init; return (IOArray marr)}
+newIOArray lu initial = stToIO $ do {marr <- newSTArray lu initial; return (IOArray marr)}
-- | Read a value from an 'IOArray'
unsafeReadIOArray :: Ix i => IOArray i e -> Int -> IO e
-- than the derived one.
instance Show HandleType where
- showsPrec p t =
+ showsPrec _ t =
case t of
ClosedHandle -> showString "closed"
SemiClosedHandle -> showString "semi-closed"
ReadWriteHandle -> showString "read-writable"
instance Show Handle where
- showsPrec p (FileHandle file _) = showHandle file
- showsPrec p (DuplexHandle file _ _) = showHandle file
+ showsPrec _ (FileHandle file _) = showHandle file
+ showsPrec _ (DuplexHandle file _ _) = showHandle file
+showHandle :: FilePath -> String -> String
showHandle file = showString "{handle: " . showString file . showString "}"
-- ------------------------------------------------------------------------
--- Exception datatype and operations
-
--- |The type of exceptions. Every kind of system-generated exception
--- has a constructor in the 'Exception' type, and values of other
--- types may be injected into 'Exception' by coercing them to
--- 'Data.Dynamic.Dynamic' (see the section on Dynamic Exceptions:
--- "Control.Exception\#DynamicExceptions").
-data Exception
- = ArithException ArithException
- -- ^Exceptions raised by arithmetic
- -- operations. (NOTE: GHC currently does not throw
- -- 'ArithException's except for 'DivideByZero').
- | ArrayException ArrayException
- -- ^Exceptions raised by array-related
- -- operations. (NOTE: GHC currently does not throw
- -- 'ArrayException's).
- | AssertionFailed String
- -- ^This exception is thrown by the
- -- 'assert' operation when the condition
- -- fails. The 'String' argument contains the
- -- location of the assertion in the source program.
- | AsyncException AsyncException
- -- ^Asynchronous exceptions (see section on Asynchronous Exceptions: "Control.Exception\#AsynchronousExceptions").
- | BlockedOnDeadMVar
- -- ^The current thread was executing a call to
- -- 'Control.Concurrent.MVar.takeMVar' that could never return,
- -- because there are no other references to this 'MVar'.
- | BlockedIndefinitely
- -- ^The current thread was waiting to retry an atomic memory transaction
- -- that could never become possible to complete because there are no other
- -- threads referring to any of the TVars involved.
- | NestedAtomically
- -- ^The runtime detected an attempt to nest one STM transaction
- -- inside another one, presumably due to the use of
- -- 'unsafePeformIO' with 'atomically'.
- | Deadlock
- -- ^There are no runnable threads, so the program is
- -- deadlocked. The 'Deadlock' exception is
- -- raised in the main thread only (see also: "Control.Concurrent").
- | DynException Dynamic
- -- ^Dynamically typed exceptions (see section on Dynamic Exceptions: "Control.Exception\#DynamicExceptions").
- | ErrorCall String
- -- ^The 'ErrorCall' exception is thrown by 'error'. The 'String'
- -- argument of 'ErrorCall' is the string passed to 'error' when it was
- -- called.
- | ExitException ExitCode
- -- ^The 'ExitException' exception is thrown by 'System.Exit.exitWith' (and
- -- 'System.Exit.exitFailure'). The 'ExitCode' argument is the value passed
- -- to 'System.Exit.exitWith'. An unhandled 'ExitException' exception in the
- -- main thread will cause the program to be terminated with the given
- -- exit code.
- | IOException IOException
- -- ^These are the standard IO exceptions generated by
- -- Haskell\'s @IO@ operations. See also "System.IO.Error".
- | NoMethodError String
- -- ^An attempt was made to invoke a class method which has
- -- no definition in this instance, and there was no default
- -- definition given in the class declaration. GHC issues a
- -- warning when you compile an instance which has missing
- -- methods.
- | NonTermination
- -- ^The current thread is stuck in an infinite loop. This
- -- exception may or may not be thrown when the program is
- -- non-terminating.
- | PatternMatchFail String
- -- ^A pattern matching failure. The 'String' argument should contain a
- -- descriptive message including the function name, source file
- -- and line number.
- | RecConError String
- -- ^An attempt was made to evaluate a field of a record
- -- for which no value was given at construction time. The
- -- 'String' argument gives the location of the
- -- record construction in the source program.
- | RecSelError String
- -- ^A field selection was attempted on a constructor that
- -- doesn\'t have the requested field. This can happen with
- -- multi-constructor records when one or more fields are
- -- missing from some of the constructors. The
- -- 'String' argument gives the location of the
- -- record selection in the source program.
- | RecUpdError String
- -- ^An attempt was made to update a field in a record,
- -- where the record doesn\'t have the requested field. This can
- -- only occur with multi-constructor records, when one or more
- -- fields are missing from some of the constructors. The
- -- 'String' argument gives the location of the
- -- record update in the source program.
-
-nonTermination :: SomeException
-nonTermination = toException NonTermination
-
--- For now at least, make the monolithic Exception type an instance of
--- the Exception class
-instance Exc.Exception Exception
+-- Exception datatypes and operations
+
+data ErrorCall = ErrorCall String
+ deriving Typeable
+
+instance Exception ErrorCall
+
+instance Show ErrorCall where
+ showsPrec _ (ErrorCall err) = showString err
+
+-----
+
+data BlockedOnDeadMVar = BlockedOnDeadMVar
+ deriving Typeable
+
+instance Exception BlockedOnDeadMVar
+
+instance Show BlockedOnDeadMVar where
+ showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"
+
+-----
+
+data BlockedIndefinitely = BlockedIndefinitely
+ deriving Typeable
+
+instance Exception BlockedIndefinitely
+
+instance Show BlockedIndefinitely where
+ showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"
+
+-----
+
+data Deadlock = Deadlock
+ deriving Typeable
+
+instance Exception Deadlock
+
+instance Show Deadlock where
+ showsPrec _ Deadlock = showString "<<deadlock>>"
+
+-----
+
+data AssertionFailed = AssertionFailed String
+ deriving Typeable
+
+instance Exception AssertionFailed
+
+instance Show AssertionFailed where
+ showsPrec _ (AssertionFailed err) = showString err
+
+-----
-- |The type of arithmetic exceptions
data ArithException
| LossOfPrecision
| DivideByZero
| Denormal
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Typeable)
+instance Exception ArithException
-- |Asynchronous exceptions
data AsyncException
-- ^This exception is raised by default in the main thread of
-- the program when the user requests to terminate the program
-- via the usual mechanism(s) (e.g. Control-C in the console).
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Typeable)
+
+instance Exception AsyncException
-- | Exceptions generated by array operations
data ArrayException
| UndefinedElement String
-- ^An attempt was made to evaluate an element of an
-- array that had not been initialized.
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Typeable)
-stackOverflow, heapOverflow :: Exception -- for the RTS
-stackOverflow = AsyncException StackOverflow
-heapOverflow = AsyncException HeapOverflow
+instance Exception ArrayException
+
+stackOverflow, heapOverflow :: SomeException -- for the RTS
+stackOverflow = toException StackOverflow
+heapOverflow = toException HeapOverflow
instance Show ArithException where
showsPrec _ Overflow = showString "arithmetic overflow"
showsPrec _ StackOverflow = showString "stack overflow"
showsPrec _ HeapOverflow = showString "heap overflow"
showsPrec _ ThreadKilled = showString "thread killed"
+ showsPrec _ UserInterrupt = showString "user interrupt"
instance Show ArrayException where
showsPrec _ (IndexOutOfBounds s)
. (if not (null s) then showString ": " . showString s
else id)
-instance Show Exception where
- showsPrec _ (IOException err) = shows err
- showsPrec _ (ArithException err) = shows err
- showsPrec _ (ArrayException err) = shows err
- showsPrec _ (ErrorCall err) = showString err
- showsPrec _ (ExitException err) = showString "exit: " . shows err
- showsPrec _ (NoMethodError err) = showString err
- showsPrec _ (PatternMatchFail err) = showString err
- showsPrec _ (RecSelError err) = showString err
- showsPrec _ (RecConError err) = showString err
- showsPrec _ (RecUpdError err) = showString err
- showsPrec _ (AssertionFailed err) = showString err
- showsPrec _ (DynException err) = showString "exception :: " . showsTypeRep (dynTypeRep err)
- showsPrec _ (AsyncException e) = shows e
- showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
- showsPrec _ (BlockedIndefinitely) = showString "thread blocked indefinitely"
- showsPrec _ (NestedAtomically) = showString "Control.Concurrent.STM.atomically was nested"
- showsPrec _ (NonTermination) = showString "<<loop>>"
- showsPrec _ (Deadlock) = showString "<<deadlock>>"
-
-instance Eq Exception where
- IOException e1 == IOException e2 = e1 == e2
- ArithException e1 == ArithException e2 = e1 == e2
- ArrayException e1 == ArrayException e2 = e1 == e2
- ErrorCall e1 == ErrorCall e2 = e1 == e2
- ExitException e1 == ExitException e2 = e1 == e2
- NoMethodError e1 == NoMethodError e2 = e1 == e2
- PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2
- RecSelError e1 == RecSelError e2 = e1 == e2
- RecConError e1 == RecConError e2 = e1 == e2
- RecUpdError e1 == RecUpdError e2 = e1 == e2
- AssertionFailed e1 == AssertionFailed e2 = e1 == e2
- DynException _ == DynException _ = False -- incomparable
- AsyncException e1 == AsyncException e2 = e1 == e2
- BlockedOnDeadMVar == BlockedOnDeadMVar = True
- NonTermination == NonTermination = True
- NestedAtomically == NestedAtomically = True
- Deadlock == Deadlock = True
- _ == _ = False
-
-- -----------------------------------------------------------------------------
-- The ExitCode type
-- The exact interpretation of the code is
-- operating-system dependent. In particular, some values
-- may be prohibited (e.g. 0 on a POSIX-compliant system).
- deriving (Eq, Ord, Read, Show)
+ deriving (Eq, Ord, Read, Show, Typeable)
+
+instance Exception ExitCode
ioException :: IOException -> IO a
-ioException err = throwIO (IOException err)
+ioException err = throwIO err
-- | Raise an 'IOError' in the 'IO' monad.
ioError :: IOError -> IO a
ioe_description :: String, -- error type specific information.
ioe_filename :: Maybe FilePath -- filename the error is related to.
}
+ deriving Typeable
+
+instance Exception IOException
instance Eq IOException where
(IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) =
(well almost; the compiler doesn't know about the IO newtype so we
have to work around that in the definition of catchException below).
-\begin{code}
+\begin{code}
catchException :: Exception e => IO a -> (e -> IO a) -> IO a
catchException (IO io) handler = IO $ catch# io handler'
where handler' e = case fromException e of
block (IO io) = IO $ blockAsyncExceptions# io
unblock (IO io) = IO $ unblockAsyncExceptions# io
+
+-- | returns True if asynchronous exceptions are blocked in the
+-- current thread.
+blocked :: IO Bool
+blocked = IO $ \s -> case asyncExceptionsBlocked# s of
+ (# s', i #) -> (# s', i /=# 0# #)
\end{code}
\begin{code}
-- because we can't have an unboxed tuple as a function argument
\end{code}
+\begin{code}
+assertError :: Addr# -> Bool -> a -> a
+assertError str predicate v
+ | predicate = v
+ | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
+
+{-
+(untangle coded message) expects "coded" to be of the form
+ "location|details"
+It prints
+ location message details
+-}
+untangle :: Addr# -> String -> String
+untangle coded message
+ = location
+ ++ ": "
+ ++ message
+ ++ details
+ ++ "\n"
+ where
+ coded_str = unpackCStringUtf8# coded
+
+ (location, details)
+ = case (span not_bar coded_str) of { (loc, rest) ->
+ case rest of
+ ('|':det) -> (loc, ' ' : det)
+ _ -> (loc, "")
+ }
+ not_bar c = c /= '|'
+\end{code}
+
projects / ghc-base.git / blobdiff