-- References
IORef(..), newIORef, readIORef, writeIORef,
- IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray,
+ IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray,
+ unsafeWriteIOArray, boundsIOArray,
MVar(..),
-- Handles, file descriptors,
ExitCode(..),
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
writeIOArray :: Ix i => IOArray i e -> i -> e -> IO ()
writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e)
+{-# INLINE boundsIOArray #-}
+boundsIOArray :: IOArray i e -> (i,i)
+boundsIOArray (IOArray marr) = boundsSTArray marr
-- ---------------------------------------------------------------------------
-- Show instance for Handles
-- 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
-
------
-
+-- |The thread is blocked on an @MVar@, but there are no other references
+-- to the @MVar@ so it can't ever continue.
data BlockedOnDeadMVar = BlockedOnDeadMVar
deriving Typeable
instance Show BlockedOnDeadMVar where
showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"
+blockedOnDeadMVar :: SomeException -- for the RTS
+blockedOnDeadMVar = toException BlockedOnDeadMVar
+
-----
+-- |The thread is awiting to retry an STM transaction, but there are no
+-- other references to any @TVar@s involved, so it can't ever continue.
data BlockedIndefinitely = BlockedIndefinitely
deriving Typeable
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)
+-- |There are no runnable threads, so the program is deadlocked.
+-- The @Deadlock@ exception is raised in the main thread only.
+data Deadlock = Deadlock
+ deriving Typeable
+
+instance Exception Deadlock
+
+instance Show Deadlock where
+ showsPrec _ Deadlock = showString "<<deadlock>>"
+
+-----
+
+-- |Exceptions generated by 'assert'. The @String@ gives information
+-- about the source location of the assertion.
+data AssertionFailed = AssertionFailed String
+ deriving Typeable
+
+instance Exception AssertionFailed
-instance Exception ArithException
+instance Show AssertionFailed where
+ showsPrec _ (AssertionFailed err) = showString err
--- |Asynchronous exceptions
+-----
+
+-- |Asynchronous exceptions.
data AsyncException
= StackOverflow
-- ^The current thread\'s stack exceeded its limit.
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)
ioe_type :: IOErrorType, -- what it was.
ioe_location :: String, -- location.
ioe_description :: String, -- error type specific information.
+ ioe_errno :: Maybe CInt, -- errno leading to this error, if any.
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) =
- e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2
+ (IOError h1 e1 loc1 str1 en1 fn1) == (IOError h2 e2 loc2 str2 en2 fn2) =
+ e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && en1==en2 && fn1==fn2
-- | An abstract type that contains a value for each variant of 'IOError'.
data IOErrorType
| 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
-- > fail s = ioError (userError s)
--
userError :: String -> IOError
-userError str = IOError Nothing UserError "" str Nothing
+userError str = IOError Nothing UserError "" str Nothing Nothing
-- ---------------------------------------------------------------------------
-- Showing IOErrors
instance Show IOException where
- showsPrec p (IOError hdl iot loc s fn) =
+ showsPrec p (IOError hdl iot loc s _ fn) =
(case fn of
Nothing -> case hdl of
Nothing -> id
catchAny (IO io) handler = IO $ catch# io handler'
where handler' (SomeException e) = unIO (handler e)
--- | A variant of 'throw' that can be used within the 'IO' monad.
+-- | A variant of 'throw' that can only be used within the 'IO' monad.
--
-- Although 'throwIO' has a type that is an instance of the type of 'throw', the
-- two functions are subtly different:
\end{code}
\begin{code}
--- | Forces its argument to be evaluated when the resultant 'IO' action
--- is executed. It can be used to order evaluation with respect to
--- other 'IO' operations; its semantics are given by
+-- | Forces its argument to be evaluated to weak head normal form when
+-- the resultant 'IO' action is executed. It can be used to order
+-- evaluation with respect to other 'IO' operations; its semantics are
+-- given by
--
-- > evaluate x `seq` y ==> y
-- > evaluate x `catch` f ==> (return $! x) `catch` f
-- 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