stackOverflow, heapOverflow, ioException,
IOError, IOException(..), IOErrorType(..), ioError, userError,
ExitCode(..),
- throwIO, block, unblock, catchAny, catchException,
+ throwIO, block, unblock, blocked, catchAny, catchException,
evaluate,
- ErrorCall(..), ArithException(..), AsyncException(..),
- BlockedOnDeadMVar(..), BlockedIndefinitely(..),
+ ErrorCall(..), AssertionFailed(..), assertError, untangle,
+ BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..),
+ blockedOnDeadMVar, blockedIndefinitely
) where
import GHC.ST
import GHC.Exception
#ifndef __HADDOCK__
-import {-# SOURCE #-} Data.Typeable ( Typeable, showsTypeRep )
-import {-# SOURCE #-} Data.Dynamic ( Dynamic, dynTypeRep )
+import {-# SOURCE #-} Data.Typeable ( Typeable )
#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 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 Show BlockedOnDeadMVar where
showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"
+blockedOnDeadMVar :: SomeException -- for the RTS
+blockedOnDeadMVar = toException BlockedOnDeadMVar
+
-----
data BlockedIndefinitely = BlockedIndefinitely
instance Show BlockedIndefinitely where
showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"
+blockedIndefinitely :: SomeException -- for the RTS
+blockedIndefinitely = toException BlockedIndefinitely
+
-----
--- |The type of arithmetic exceptions
-data ArithException
- = Overflow
- | Underflow
- | LossOfPrecision
- | DivideByZero
- | Denormal
- deriving (Eq, Ord, Typeable)
+data Deadlock = Deadlock
+ deriving Typeable
+
+instance Exception Deadlock
+
+instance Show Deadlock where
+ showsPrec _ Deadlock = showString "<<deadlock>>"
+
+-----
-instance Exception ArithException
+data AssertionFailed = AssertionFailed String
+ deriving Typeable
+
+instance Exception AssertionFailed
+
+instance Show AssertionFailed where
+ showsPrec _ (AssertionFailed err) = showString err
+
+-----
-- |Asynchronous exceptions
data AsyncException
stackOverflow = toException StackOverflow
heapOverflow = toException HeapOverflow
-instance Show ArithException where
- showsPrec _ Overflow = showString "arithmetic overflow"
- showsPrec _ Underflow = showString "arithmetic underflow"
- showsPrec _ LossOfPrecision = showString "loss of precision"
- showsPrec _ DivideByZero = showString "divide by zero"
- showsPrec _ Denormal = showString "denormal"
-
instance Show AsyncException where
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)
| TimeExpired
| ResourceVanished
| Interrupted
- | DynIOError Dynamic -- cheap&cheerful extensible IO error type.
instance Eq IOErrorType where
- x == y =
- case x of
- DynIOError{} -> False -- from a strictness POV, compatible with a derived Eq inst?
- _ -> getTag x ==# getTag y
+ x == y = getTag x ==# getTag y
instance Show IOErrorType where
showsPrec _ e =
TimeExpired -> "timeout"
UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
UnsupportedOperation -> "unsupported operation"
- DynIOError{} -> "unknown IO error"
-- | Construct an 'IOError' value with a string describing the error.
-- The 'fail' method of the 'IO' instance of the 'Monad' class raises a
(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