\begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-}
+{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.IOBase
unsafePerformIO, unsafeInterleaveIO,
unsafeDupablePerformIO, unsafeDupableInterleaveIO,
noDuplicate,
-
- -- To and from from ST
+
+ -- To and from from ST
stToIO, ioToST, unsafeIOToST, unsafeSTToIO,
- -- References
+ -- References
IORef(..), newIORef, readIORef, writeIORef,
IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray,
MVar(..),
- -- Handles, file descriptors,
+ -- Handles, file descriptors,
FilePath,
Handle(..), Handle__(..), HandleType(..), IOMode(..), FD,
isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle,
-
- -- Buffers
+
+ -- Buffers
Buffer(..), RawBuffer, BufferState(..), BufferList(..), BufferMode(..),
bufferIsWritable, bufferEmpty, bufferFull,
- -- Exceptions
+ -- Exceptions
Exception(..), ArithException(..), AsyncException(..), ArrayException(..),
- stackOverflow, heapOverflow, throw, throwIO, ioException,
+ stackOverflow, heapOverflow, ioException,
IOError, IOException(..), IOErrorType(..), ioError, userError,
- ExitCode(..)
+ ExitCode(..),
+ throwIO, block, unblock, blocked, catchAny, catchException,
+ evaluate,
+ ErrorCall(..), AssertionFailed(..), assertError, untangle,
+ BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..)
) where
-
+
import GHC.ST
-import GHC.Arr -- to derive Ix class
+import GHC.Arr -- to derive Ix class
import GHC.Enum -- to derive Enum class
import GHC.STRef
import GHC.Base
--- import GHC.Num -- To get fromInteger etc, needed because of -fno-implicit-prelude
+-- import GHC.Num -- To get fromInteger etc, needed because of -XNoImplicitPrelude
import Data.Maybe ( Maybe(..) )
import GHC.Show
import GHC.List
import GHC.Read
import Foreign.C.Types (CInt)
+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
-- ---------------------------------------------------------------------------
Compiler - types of various primitives in PrimOp.lhs
-RTS - forceIO (StgMiscClosures.hc)
- - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
- (Exceptions.hc)
- - raiseAsync (Schedule.c)
+RTS - forceIO (StgMiscClosures.hc)
+ - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
+ (Exceptions.hc)
+ - raiseAsync (Schedule.c)
Prelude - GHC.IOBase.lhs, and several other places including
- GHC.Exception.lhs.
+ GHC.Exception.lhs.
Libraries - parts of hslibs/lang.
{-# INLINE (>>) #-}
{-# INLINE (>>=) #-}
m >> k = m >>= \ _ -> k
- return x = returnIO x
+ return x = returnIO x
m >>= k = bindIO m k
- fail s = failIO s
+ fail s = failIO s
failIO :: String -> IO a
failIO s = ioError (userError s)
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
-- monad. The 'RealWorld' parameter indicates that the internal state
-- used by the 'ST' computation is a special one supplied by the 'IO'
-- monad, and thus distinct from those used by invocations of 'runST'.
-stToIO :: ST RealWorld a -> IO a
+stToIO :: ST RealWorld a -> IO a
stToIO (ST m) = IO m
-ioToST :: IO a -> ST RealWorld a
+ioToST :: IO a -> ST RealWorld a
ioToST (IO m) = (ST m)
-- This relies on IO and ST having the same representation modulo the
writing and compiling modules that use 'unsafePerformIO':
* Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@
- that calls 'unsafePerformIO'. If the call is inlined,
- the I\/O may be performed more than once.
+ that calls 'unsafePerformIO'. If the call is inlined,
+ the I\/O may be performed more than once.
* Use the compiler flag @-fno-cse@ to prevent common sub-expression
- elimination being performed on the module, which might combine
- two side effects that were meant to be separate. A good example
- is using multiple global variables (like @test@ in the example below).
+ elimination being performed on the module, which might combine
+ two side effects that were meant to be separate. A good example
+ is using multiple global variables (like @test@ in the example below).
* Make sure that the either you switch off let-floating, or that the
- call to 'unsafePerformIO' cannot float outside a lambda. For example,
- if you say:
- @
- f x = unsafePerformIO (newIORef [])
- @
- you may get only one reference cell shared between all calls to @f@.
- Better would be
- @
- f x = unsafePerformIO (newIORef [x])
- @
- because now it can't float outside the lambda.
+ call to 'unsafePerformIO' cannot float outside a lambda. For example,
+ if you say:
+ @
+ f x = unsafePerformIO (newIORef [])
+ @
+ you may get only one reference cell shared between all calls to @f@.
+ Better would be
+ @
+ f x = unsafePerformIO (newIORef [x])
+ @
+ because now it can't float outside the lambda.
It is less well known that
'unsafePerformIO' is not type safe. For example:
> test = unsafePerformIO $ newIORef []
>
> main = do
-> writeIORef test [42]
-> bang <- readIORef test
-> print (bang :: [Char])
+> writeIORef test [42]
+> bang <- readIORef test
+> print (bang :: [Char])
This program will core dump. This problem with polymorphic references
is well known in the ML community, and does not arise with normal
possible to write @coerce :: a -> b@ with the
help of 'unsafePerformIO'. So be careful!
-}
-unsafePerformIO :: IO a -> a
+unsafePerformIO :: IO a -> a
unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m)
{-|
it gives the same results each time.
-}
{-# NOINLINE unsafeDupablePerformIO #-}
-unsafeDupablePerformIO :: IO a -> a
+unsafeDupablePerformIO :: IO a -> a
unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
-- Why do we NOINLINE unsafeDupablePerformIO? See the comment with
-- If we don't have it, the demand analyser discovers the following strictness
-- for unsafeDupablePerformIO: C(U(AV))
-- But then consider
--- unsafeDupablePerformIO (\s -> let r = f x in
--- case writeIORef v r s of (# s1, _ #) ->
--- (# s1, r #)
+-- unsafeDupablePerformIO (\s -> let r = f x in
+-- case writeIORef v r s of (# s1, _ #) ->
+-- (# s1, r #)
-- The strictness analyser will find that the binding for r is strict,
-- (becuase of uPIO's strictness sig), and so it'll evaluate it before
-- doing the writeIORef. This actually makes tests/lib/should_run/memo002
-- get a deadlock!
--
-- Solution: don't expose the strictness of unsafeDupablePerformIO,
--- by hiding it with 'lazy'
+-- by hiding it with 'lazy'
{-|
'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily.
unsafeDupableInterleaveIO :: IO a -> IO a
unsafeDupableInterleaveIO (IO m)
= IO ( \ s -> let
- r = case m s of (# _, res #) -> res
- in
- (# s, r #))
+ r = case m s of (# _, res #) -> res
+ in
+ (# s, r #))
{-|
Ensures that the suspensions under evaluation by the current thread
-- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module
instance Eq (MVar a) where
- (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
+ (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
-- A Handle is represented by (a reference to) a record
-- containing the state of the I/O port/device. We record
-- * buffering mode
-- * buffer, and spare buffers
-- * user-friendly name (usually the
--- FilePath used when IO.openFile was called)
+-- FilePath used when IO.openFile was called)
-- Note: when a Handle is garbage collected, we want to flush its buffer
-- and close the OS file handle, so as to free up a (precious) resource.
-- ensure that this doesn't happen.
data Handle
- = FileHandle -- A normal handle to a file
- FilePath -- the file (invariant)
- !(MVar Handle__)
+ = FileHandle -- A normal handle to a file
+ FilePath -- the file (invariant)
+ !(MVar Handle__)
- | DuplexHandle -- A handle to a read/write stream
- FilePath -- file for a FIFO, otherwise some
- -- descriptive string.
- !(MVar Handle__) -- The read side
- !(MVar Handle__) -- The write side
+ | DuplexHandle -- A handle to a read/write stream
+ FilePath -- file for a FIFO, otherwise some
+ -- descriptive string.
+ !(MVar Handle__) -- The read side
+ !(MVar Handle__) -- The write side
-- NOTES:
-- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be
data Handle__
= Handle__ {
- haFD :: !FD, -- file descriptor
- haType :: HandleType, -- type (read/write/append etc.)
- haIsBin :: Bool, -- binary mode?
- haIsStream :: Bool, -- Windows : is this a socket?
+ haFD :: !FD, -- file descriptor
+ haType :: HandleType, -- type (read/write/append etc.)
+ haIsBin :: Bool, -- binary mode?
+ haIsStream :: Bool, -- Windows : is this a socket?
-- Unix : is O_NONBLOCK set?
- haBufferMode :: BufferMode, -- buffer contains read/write data?
- haBuffer :: !(IORef Buffer), -- the current buffer
+ haBufferMode :: BufferMode, -- buffer contains read/write data?
+ haBuffer :: !(IORef Buffer), -- the current buffer
haBuffers :: !(IORef BufferList), -- spare buffers
haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a
- -- duplex handle.
+ -- duplex handle.
}
-- ---------------------------------------------------------------------------
data Buffer
= Buffer {
- bufBuf :: RawBuffer,
- bufRPtr :: !Int,
- bufWPtr :: !Int,
- bufSize :: !Int,
- bufState :: BufferState
+ bufBuf :: RawBuffer,
+ bufRPtr :: !Int,
+ bufWPtr :: !Int,
+ bufSize :: !Int,
+ bufState :: BufferState
}
data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
| AppendHandle
| ReadWriteHandle
+isReadableHandleType :: HandleType -> Bool
isReadableHandleType ReadHandle = True
isReadableHandleType ReadWriteHandle = True
-isReadableHandleType _ = False
+isReadableHandleType _ = False
+isWritableHandleType :: HandleType -> Bool
isWritableHandleType AppendHandle = True
isWritableHandleType WriteHandle = True
isWritableHandleType ReadWriteHandle = True
-isWritableHandleType _ = False
+isWritableHandleType _ = False
+isReadWriteHandleType :: HandleType -> Bool
isReadWriteHandleType ReadWriteHandle{} = True
isReadWriteHandleType _ = False
-- and terminals will normally be line-buffered.
data BufferMode
- = NoBuffering -- ^ buffering is disabled if possible.
+ = NoBuffering -- ^ buffering is disabled if possible.
| LineBuffering
- -- ^ line-buffering should be enabled if possible.
+ -- ^ line-buffering should be enabled if possible.
| BlockBuffering (Maybe Int)
- -- ^ block-buffering should be enabled if possible.
- -- The size of the buffer is @n@ items if the argument
- -- is 'Just' @n@ and is otherwise implementation-dependent.
+ -- ^ block-buffering should be enabled if possible.
+ -- The size of the buffer is @n@ items if the argument
+ -- is 'Just' @n@ and is otherwise implementation-dependent.
deriving (Eq, Ord, Read, Show)
-- ---------------------------------------------------------------------------
-- |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.
+-- 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
= StackOverflow
- -- ^The current thread\'s stack exceeded its limit.
- -- Since an exception has been raised, the thread\'s stack
- -- will certainly be below its limit again, but the
- -- programmer should take remedial action
- -- immediately.
+ -- ^The current thread\'s stack exceeded its limit.
+ -- Since an exception has been raised, the thread\'s stack
+ -- will certainly be below its limit again, but the
+ -- programmer should take remedial action
+ -- immediately.
| HeapOverflow
- -- ^The program\'s heap is reaching its limit, and
- -- the program should take action to reduce the amount of
- -- live data it has. Notes:
- --
- -- * It is undefined which thread receives this exception.
- --
- -- * GHC currently does not throw 'HeapOverflow' exceptions.
+ -- ^The program\'s heap is reaching its limit, and
+ -- the program should take action to reduce the amount of
+ -- live data it has. Notes:
+ --
+ -- * It is undefined which thread receives this exception.
+ --
+ -- * GHC currently does not throw 'HeapOverflow' exceptions.
| ThreadKilled
- -- ^This exception is raised by another thread
- -- calling 'Control.Concurrent.killThread', or by the system
- -- if it needs to terminate the thread for some
- -- reason.
- deriving (Eq, Ord)
+ -- ^This exception is raised by another thread
+ -- calling 'Control.Concurrent.killThread', or by the system
+ -- if it needs to terminate the thread for some
+ -- reason.
+ | UserInterrupt
+ -- ^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, Typeable)
+
+instance Exception AsyncException
-- | Exceptions generated by array operations
data ArrayException
- = IndexOutOfBounds String
- -- ^An attempt was made to index an array outside
- -- its declared bounds.
- | UndefinedElement String
- -- ^An attempt was made to evaluate an element of an
- -- array that had not been initialized.
- deriving (Eq, Ord)
-
-stackOverflow, heapOverflow :: Exception -- for the RTS
-stackOverflow = AsyncException StackOverflow
-heapOverflow = AsyncException HeapOverflow
+ = IndexOutOfBounds String
+ -- ^An attempt was made to index an array outside
+ -- its declared bounds.
+ | UndefinedElement String
+ -- ^An attempt was made to evaluate an element of an
+ -- array that had not been initialized.
+ deriving (Eq, Ord, Typeable)
+
+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)
- = showString "array index out of range"
- . (if not (null s) then showString ": " . showString s
- else id)
+ = showString "array index out of range"
+ . (if not (null s) then showString ": " . showString s
+ else id)
showsPrec _ (UndefinedElement s)
- = showString "undefined array element"
- . (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
+ = showString "undefined array element"
+ . (if not (null s) then showString ": " . showString s
+ else id)
-- -----------------------------------------------------------------------------
-- The ExitCode type
-- Exception datatype (above).
data ExitCode
- = ExitSuccess -- ^ indicates successful termination;
+ = ExitSuccess -- ^ indicates successful termination;
| ExitFailure Int
- -- ^ indicates program failure with an exit code.
- -- 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)
-
--- --------------------------------------------------------------------------
--- Primitive throw
+ -- ^ indicates program failure with an exit code.
+ -- 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, Typeable)
--- | Throw an exception. Exceptions may be thrown from purely
--- functional code, but may only be caught within the 'IO' monad.
-throw :: Exception -> a
-throw exception = raise# exception
-
--- | A variant of 'throw' that can 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:
---
--- > throw e `seq` x ===> throw e
--- > throwIO e `seq` x ===> x
---
--- The first example will cause the exception @e@ to be raised,
--- whereas the second one won\'t. In fact, 'throwIO' will only cause
--- an exception to be raised when it is used within the 'IO' monad.
--- The 'throwIO' variant should be used in preference to 'throw' to
--- raise an exception within the 'IO' monad because it guarantees
--- ordering with respect to other 'IO' operations, whereas 'throw'
--- does not.
-throwIO :: Exception -> IO a
-throwIO err = IO $ raiseIO# err
+instance Exception ExitCode
-ioException :: IOException -> IO a
-ioException err = IO $ raiseIO# (IOException err)
+ioException :: IOException -> IO a
+ioException err = throwIO err
-- | Raise an 'IOError' in the 'IO' monad.
ioError :: IOError -> IO a
-ioError = ioException
+ioError = ioException
-- ---------------------------------------------------------------------------
-- IOError type
data IOException
= IOError {
ioe_handle :: Maybe Handle, -- the handle used by the action flagging
- -- the error.
+ -- the error.
ioe_type :: IOErrorType, -- what it was.
- ioe_location :: String, -- location.
+ ioe_location :: String, -- location.
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) =
showsPrec _ e =
showString $
case e of
- AlreadyExists -> "already exists"
+ AlreadyExists -> "already exists"
NoSuchThing -> "does not exist"
ResourceBusy -> "resource busy"
ResourceExhausted -> "resource exhausted"
- EOF -> "end of file"
- IllegalOperation -> "illegal operation"
+ EOF -> "end of file"
+ IllegalOperation -> "illegal operation"
PermissionDenied -> "permission denied"
- UserError -> "user error"
- HardwareFault -> "hardware fault"
+ UserError -> "user error"
+ HardwareFault -> "hardware fault"
InappropriateType -> "inappropriate type"
Interrupted -> "interrupted"
InvalidArgument -> "invalid argument"
OtherError -> "failed"
ProtocolError -> "protocol error"
ResourceVanished -> "resource vanished"
- SystemError -> "system error"
+ SystemError -> "system error"
TimeExpired -> "timeout"
UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
UnsupportedOperation -> "unsupported operation"
-- > fail s = ioError (userError s)
--
userError :: String -> IOError
-userError str = IOError Nothing UserError "" str Nothing
+userError str = IOError Nothing UserError "" str Nothing
-- ---------------------------------------------------------------------------
-- Showing IOErrors
instance Show IOException where
showsPrec p (IOError hdl iot loc s fn) =
(case fn of
- Nothing -> case hdl of
- Nothing -> id
- Just h -> showsPrec p h . showString ": "
- Just name -> showString name . showString ": ") .
+ Nothing -> case hdl of
+ Nothing -> id
+ Just h -> showsPrec p h . showString ": "
+ Just name -> showString name . showString ": ") .
(case loc of
"" -> id
- _ -> showString loc . showString ": ") .
+ _ -> showString loc . showString ": ") .
showsPrec p iot .
(case s of
- "" -> id
- _ -> showString " (" . showString s . showString ")")
+ "" -> id
+ _ -> showString " (" . showString s . showString ")")
-- -----------------------------------------------------------------------------
-- IOMode type
data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
deriving (Eq, Ord, Ix, Enum, Read, Show)
\end{code}
+
+%*********************************************************
+%* *
+\subsection{Primitive catch and throwIO}
+%* *
+%*********************************************************
+
+catchException used to handle the passing around of the state to the
+action and the handler. This turned out to be a bad idea - it meant
+that we had to wrap both arguments in thunks so they could be entered
+as normal (remember IO returns an unboxed pair...).
+
+Now catch# has type
+
+ catch# :: IO a -> (b -> IO a) -> IO 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}
+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
+ Just e' -> unIO (handler e')
+ Nothing -> raise# e
+
+catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a
+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.
+--
+-- Although 'throwIO' has a type that is an instance of the type of 'throw', the
+-- two functions are subtly different:
+--
+-- > throw e `seq` x ===> throw e
+-- > throwIO e `seq` x ===> x
+--
+-- The first example will cause the exception @e@ to be raised,
+-- whereas the second one won\'t. In fact, 'throwIO' will only cause
+-- an exception to be raised when it is used within the 'IO' monad.
+-- The 'throwIO' variant should be used in preference to 'throw' to
+-- raise an exception within the 'IO' monad because it guarantees
+-- ordering with respect to other 'IO' operations, whereas 'throw'
+-- does not.
+throwIO :: Exception e => e -> IO a
+throwIO e = IO (raiseIO# (toException e))
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Controlling asynchronous exception delivery}
+%* *
+%*********************************************************
+
+\begin{code}
+-- | Applying 'block' to a computation will
+-- execute that computation with asynchronous exceptions
+-- /blocked/. That is, any thread which
+-- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be
+-- blocked until asynchronous exceptions are enabled again. There\'s
+-- no need to worry about re-enabling asynchronous exceptions; that is
+-- done automatically on exiting the scope of
+-- 'block'.
+--
+-- Threads created by 'Control.Concurrent.forkIO' inherit the blocked
+-- state from the parent; that is, to start a thread in blocked mode,
+-- use @block $ forkIO ...@. This is particularly useful if you need to
+-- establish an exception handler in the forked thread before any
+-- asynchronous exceptions are received.
+block :: IO a -> IO a
+
+-- | To re-enable asynchronous exceptions inside the scope of
+-- 'block', 'unblock' can be
+-- used. It scopes in exactly the same way, so on exit from
+-- 'unblock' asynchronous exception delivery will
+-- be disabled again.
+unblock :: IO a -> IO a
+
+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}
+-- | 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
+--
+-- > evaluate x `seq` y ==> y
+-- > evaluate x `catch` f ==> (return $! x) `catch` f
+-- > evaluate x >>= f ==> (return $! x) >>= f
+--
+-- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the
+-- same as @(return $! x)@. A correct definition is
+--
+-- > evaluate x = (return $! x) >>= return
+--
+evaluate :: a -> IO a
+evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #)
+ -- NB. can't write
+ -- a `seq` (# s, a #)
+ -- 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