+% ------------------------------------------------------------------------------
+% $Id: PrelIOBase.lhs,v 1.38 2001/05/18 16:54:05 simonmar Exp $
+%
+% (c) The University of Glasgow, 1994-2001
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
-%
-
-\section[PrelIOBase]{Module @PrelIOBase@}
-Definitions for the @IO@ monad and its friends. Everything is exported
-concretely; the @IO@ module itself exports abstractly.
+% Definitions for the @IO@ monad and its friends. Everything is exported
+% concretely; the @IO@ module itself exports abstractly.
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
-#include "error.h"
+#include "config.h"
module PrelIOBase where
-import {-# SOURCE #-} PrelErr ( error )
import PrelST
-import PrelTup
-import PrelMaybe
-import PrelAddr
-import PrelPack ( unpackCString )
+import PrelArr
import PrelBase
-import PrelArr ( ByteArray(..), MutableVar )
-import PrelGHC
+import PrelNum -- To get fromInteger etc, needed because of -fno-implicit-prelude
+import PrelMaybe ( Maybe(..) )
+import PrelShow
+import PrelList
+import PrelDynamic
-\end{code}
+-- ---------------------------------------------------------------------------
+-- The IO Monad
-%*********************************************************
-%* *
-\subsection{The @IO@ monad}
-%* *
-%*********************************************************
+{-
+The IO Monad is just an instance of the ST monad, where the state is
+the real world. We use the exception mechanism (in PrelException) to
+implement IO exceptions.
-IO is no longer built on top of PrimIO (which used to be a specialised
-version of the ST monad), instead it is now has its own type. This is
-purely for efficiency purposes, since we get to remove several levels
-of lifting in the type of the monad.
+NOTE: The IO representation is deeply wired in to various parts of the
+system. The following list may or may not be exhaustive:
-\begin{code}
-newtype IO a = IO (State# RealWorld -> IOResult a)
+Compiler - types of various primitives in PrimOp.lhs
-{-# INLINE unIO #-}
-unIO (IO a) = a
+RTS - forceIO (StgMiscClosures.hc)
+ - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
+ (Exceptions.hc)
+ - raiseAsync (Schedule.c)
+
+Prelude - PrelIOBase.lhs, and several other places including
+ PrelException.lhs.
-data IOResult a = IOok (State# RealWorld) a
- | IOfail (State# RealWorld) IOError
+Libraries - parts of hslibs/lang.
+
+--SDM
+-}
+
+newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
+
+unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
+unIO (IO a) = a
instance Functor IO where
- map f x = x >>= (return . f)
+ fmap f x = x >>= (return . f)
instance Monad IO where
{-# INLINE return #-}
{-# INLINE (>>) #-}
{-# INLINE (>>=) #-}
m >> k = m >>= \ _ -> k
- return x = IO $ \ s -> IOok s x
-
- (IO m) >>= k =
- IO $ \s ->
- case m s of
- IOfail new_s err -> IOfail new_s err
- IOok new_s a -> unIO (k a) new_s
-
-fixIO :: (a -> IO a) -> IO a
- -- not required but worth having around
-
-fixIO k = IO $ \ s ->
- let
- (IO k_loop) = k loop
- result = k_loop s
- IOok _ loop = result
- in
- result
-
-fail :: IOError -> IO a
-fail err = IO $ \ s -> IOfail s err
-
-userError :: String -> IOError
-userError str = IOError Nothing UserError str
-
-catch :: IO a -> (IOError -> IO a) -> IO a
-catch (IO m) k = IO $ \ s ->
- case m s of
- IOok new_s a -> IOok new_s a
- IOfail new_s e -> unIO (k e) new_s
-
-instance Show (IO a) where
- showsPrec p f = showString "<<IO action>>"
- showList = showList__ (showsPrec 0)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Coercions to @ST@}
-%* *
-%*********************************************************
-
-\begin{code}
-stToIO :: ST RealWorld a -> IO a
-stToIO (ST m) = IO $ \ s -> case (m s) of STret new_s r -> IOok new_s r
-
-ioToST :: IO a -> ST RealWorld a
-ioToST (IO io) = ST $ \ s ->
- case (io s) of
- IOok new_s a -> STret new_s a
- IOfail new_s e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n")
-\end{code}
+ return x = returnIO x
-%*********************************************************
-%* *
-\subsection{Utility functions}
-%* *
-%*********************************************************
+ m >>= k = bindIO m k
+ fail s = failIO s
-I'm not sure why this little function is here...
+failIO :: String -> IO a
+failIO s = ioError (userError s)
-\begin{code}
-fputs :: Addr{-FILE*-} -> String -> IO Bool
+liftIO :: IO a -> State# RealWorld -> STret RealWorld a
+liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
-fputs stream [] = return True
+bindIO :: IO a -> (a -> IO b) -> IO b
+bindIO (IO m) k = IO ( \ s ->
+ case m s of
+ (# new_s, a #) -> unIO (k a) new_s
+ )
-fputs stream (c : cs)
- = _ccall_ stg_putc c stream >> -- stg_putc expands to putc
- fputs stream cs -- (just does some casting stream)
-\end{code}
+returnIO :: a -> IO a
+returnIO x = IO (\ s -> (# s, x #))
+-- ---------------------------------------------------------------------------
+-- Coercions between IO and ST
-%*********************************************************
-%* *
-\subsection{Type @IOError@}
-%* *
-%*********************************************************
+--stToIO :: (forall s. ST s a) -> IO a
+stToIO :: ST RealWorld a -> IO a
+stToIO (ST m) = IO m
-A value @IOError@ encode errors occurred in the @IO@ monad.
-An @IOError@ records a more specific error type, a descriptive
-string and maybe the handle that was used when the error was
-flagged.
+ioToST :: IO a -> ST RealWorld a
+ioToST (IO m) = (ST m)
-\begin{code}
-data IOError
- = IOError
- (Maybe Handle) -- the handle used by the action flagging the
- -- the error.
- IOErrorType -- what it was.
- String -- error type specific information.
-
-
-data IOErrorType
- = AlreadyExists | HardwareFault
- | IllegalOperation | InappropriateType
- | Interrupted | InvalidArgument
- | NoSuchThing | OtherError
- | PermissionDenied | ProtocolError
- | ResourceBusy | ResourceExhausted
- | ResourceVanished | SystemError
- | TimeExpired | UnsatisfiedConstraints
- | UnsupportedOperation | UserError
- | EOF
- deriving (Eq, Show)
+-- ---------------------------------------------------------------------------
+-- Unsafe IO operations
-\end{code}
+{-# NOINLINE unsafePerformIO #-}
+unsafePerformIO :: IO a -> a
+unsafePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
-Predicates on IOError; little effort made on these so far...
+{-# NOINLINE unsafeInterleaveIO #-}
+unsafeInterleaveIO :: IO a -> IO a
+unsafeInterleaveIO (IO m)
+ = IO ( \ s -> let
+ r = case m s of (# _, res #) -> res
+ in
+ (# s, r #))
-\begin{code}
+-- ---------------------------------------------------------------------------
+-- Handle type
-isAlreadyExistsError (IOError _ AlreadyExists _) = True
-isAlreadyExistsError _ = False
+data MVar a = MVar (MVar# RealWorld a)
-isAlreadyInUseError (IOError _ ResourceBusy _) = True
-isAlreadyInUseError _ = False
+-- pull in Eq (Mvar a) too, to avoid PrelConc being an orphan-instance module
+instance Eq (MVar a) where
+ (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
-isFullError (IOError _ ResourceExhausted _) = True
-isFullError _ = False
+-- A Handle is represented by (a reference to) a record
+-- containing the state of the I/O port/device. We record
+-- the following pieces of info:
-isEOFError (IOError _ EOF _) = True
-isEOFError _ = True
+-- * type (read,write,closed etc.)
+-- * the underlying file descriptor
+-- * buffering mode
+-- * buffer, and spare buffers
+-- * user-friendly name (usually the
+-- FilePath used when IO.openFile was called)
-isIllegalOperation (IOError _ IllegalOperation _) = True
-isIllegalOperation _ = False
+-- 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.
-isPermissionError (IOError _ PermissionDenied _) = True
-isPermissionError _ = False
+data Handle
+ = FileHandle -- A normal handle to a file
+ !(MVar Handle__)
-isDoesNotExistError (IOError _ NoSuchThing _) = True
-isDoesNotExistError _ = False
+ | DuplexHandle -- A handle to a read/write stream
+ !(MVar Handle__) -- The read side
+ !(MVar Handle__) -- The write side
-isUserError (IOError _ UserError _) = True
-isUserError _ = False
-\end{code}
+-- NOTES:
+-- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be
+-- seekable.
-Showing @IOError@s
+instance Eq Handle where
+ (FileHandle h1) == (FileHandle h2) = h1 == h2
+ (DuplexHandle h1 _) == (DuplexHandle h2 _) = h1 == h2
+ _ == _ = False
-\begin{code}
-instance Show IOError where
- showsPrec p (IOError _ UserError s) rs =
- showString s rs
-{-
- showsPrec p (IOError _ EOF _) rs =
- showsPrec p EOF rs
--}
- showsPrec p (IOError _ iot s) rs =
- showsPrec p
- iot
- (case s of {
- "" -> rs;
- _ -> showString ": " $
- showString s rs})
+type FD = Int -- XXX ToDo: should be CInt
-\end{code}
-
-The @String@ part of an @IOError@ is platform-dependent. However, to
-provide a uniform mechanism for distinguishing among errors within
-these broad categories, each platform-specific standard shall specify
-the exact strings to be used for particular errors. For errors not
-explicitly mentioned in the standard, any descriptive string may be
-used.
+data Handle__
+ = Handle__ {
+ haFD :: !FD,
+ haType :: HandleType,
+ haBufferMode :: BufferMode,
+ haFilePath :: FilePath,
+ haBuffer :: !(IORef Buffer),
+ haBuffers :: !(IORef BufferList)
+ }
+
+-- ---------------------------------------------------------------------------
+-- Buffers
+
+-- The buffer is represented by a mutable variable containing a
+-- record, where the record contains the raw buffer and the start/end
+-- points of the filled portion. We use a mutable variable so that
+-- the common operation of writing (or reading) some data from (to)
+-- the buffer doesn't need to modify, and hence copy, the handle
+-- itself, it just updates the buffer.
+
+-- There will be some allocation involved in a simple hPutChar in
+-- order to create the new Buffer structure (below), but this is
+-- relatively small, and this only has to be done once per write
+-- operation.
+
+-- The buffer contains its size - we could also get the size by
+-- calling sizeOfMutableByteArray# on the raw buffer, but that tends
+-- to be rounded up to the nearest Word.
+
+type RawBuffer = MutableByteArray# RealWorld
+
+-- INVARIANTS on a Buffer:
+--
+-- * A handle *always* has a buffer, even if it is only 1 character long
+-- (an unbuffered handle needs a 1 character buffer in order to support
+-- hLookAhead and hIsEOF).
+-- * r <= w
+-- * if r == w, then r == 0 && w == 0
+-- * if state == WriteBuffer, then r == 0
+-- * a write buffer is never full. If an operation
+-- fills up the buffer, it will always flush it before
+-- returning.
+-- * a read buffer may be full as a result of hLookAhead. In normal
+-- operation, a read buffer always has at least one character of space.
+
+data Buffer
+ = Buffer {
+ bufBuf :: RawBuffer,
+ bufRPtr :: !Int,
+ bufWPtr :: !Int,
+ bufSize :: !Int,
+ bufState :: BufferState
+ }
+
+data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
+
+-- we keep a few spare buffers around in a handle to avoid allocating
+-- a new one for each hPutStr. These buffers are *guaranteed* to be the
+-- same size as the main buffer.
+data BufferList
+ = BufferListNil
+ | BufferListCons RawBuffer BufferList
+
+
+bufferIsWritable :: Buffer -> Bool
+bufferIsWritable Buffer{ bufState=WriteBuffer } = True
+bufferIsWritable _other = False
+
+bufferEmpty :: Buffer -> Bool
+bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } | r == w = True
+bufferEmpty _other = False
+
+-- only makes sense for a write buffer
+bufferFull :: Buffer -> Bool
+bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b
+
+-- Internally, we classify handles as being one
+-- of the following:
+
+data HandleType
+ = ClosedHandle
+ | SemiClosedHandle
+ | ReadHandle
+ | WriteHandle
+ | AppendHandle
+ | ReadWriteHandle
+ | ReadSideHandle !(MVar Handle__) -- read side of a duplex handle
+
+-- File names are specified using @FilePath@, a OS-dependent
+-- string that (hopefully, I guess) maps to an accessible file/object.
+
+type FilePath = String
+
+-- ---------------------------------------------------------------------------
+-- Buffering modes
+
+-- Three kinds of buffering are supported: line-buffering,
+-- block-buffering or no-buffering. These modes have the following
+-- effects. For output, items are written out from the internal
+-- buffer according to the buffer mode:
+--
+-- * line-buffering the entire output buffer is written
+-- out whenever a newline is output, the output buffer overflows,
+-- a flush is issued, or the handle is closed.
+--
+-- * block-buffering the entire output buffer is written out whenever
+-- it overflows, a flush is issued, or the handle
+-- is closed.
+--
+-- * no-buffering output is written immediately, and never stored
+-- in the output buffer.
+--
+-- The output buffer is emptied as soon as it has been written out.
+
+-- Similarly, input occurs according to the buffer mode for handle {\em hdl}.
+
+-- * line-buffering when the input buffer for the handle is not empty,
+-- the next item is obtained from the buffer;
+-- otherwise, when the input buffer is empty,
+-- characters up to and including the next newline
+-- character are read into the buffer. No characters
+-- are available until the newline character is
+-- available.
+--
+-- * block-buffering when the input buffer for the handle becomes empty,
+-- the next block of data is read into this buffer.
+--
+-- * no-buffering the next input item is read and returned.
+
+-- For most implementations, physical files will normally be block-buffered
+-- and terminals will normally be line-buffered. (the IO interface provides
+-- operations for changing the default buffering of a handle tho.)
-\begin{code}
-constructErrorAndFail :: String -> IO a
-constructErrorAndFail call_site
- = constructError call_site >>= \ io_error ->
- fail io_error
+data BufferMode
+ = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
+ deriving (Eq, Ord, Show)
+ {- Read instance defined in IO. -}
-constructErrorAndFailWithInfo :: String -> String -> IO a
-constructErrorAndFailWithInfo call_site reason
- = constructErrorMsg call_site (Just reason) >>= \ io_error ->
- fail io_error
+-- ---------------------------------------------------------------------------
+-- IORefs
-\end{code}
+newtype IORef a = IORef (STRef RealWorld a) deriving Eq
-This doesn't seem to be documented/spelled out anywhere,
-so here goes: (SOF)
+newIORef :: a -> IO (IORef a)
+newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)
-The implementation of the IO prelude uses various C stubs
-to do the actual interaction with the OS. The bandwidth
-\tr{C<->Haskell} is somewhat limited, so the general strategy
-for flaggging any errors (apart from possibly using the
-return code of the external call), is to set the @ghc_errtype@
-to a value that is one of the \tr{#define}s in @includes/error.h@.
-@ghc_errstr@ holds a character string providing error-specific
-information.
+readIORef :: IORef a -> IO a
+readIORef (IORef var) = stToIO (readSTRef var)
-\begin{code}
-constructError :: String -> IO IOError
-constructError call_site = constructErrorMsg call_site Nothing
-
-constructErrorMsg :: String -> Maybe String -> IO IOError
-constructErrorMsg call_site reason =
- _casm_ ``%r = ghc_errtype;'' >>= \ (I# errtype#) ->
- _casm_ ``%r = ghc_errstr;'' >>= \ str ->
- let
- iot =
- case errtype# of
- ERR_ALREADYEXISTS# -> AlreadyExists
- ERR_HARDWAREFAULT# -> HardwareFault
- ERR_ILLEGALOPERATION# -> IllegalOperation
- ERR_INAPPROPRIATETYPE# -> InappropriateType
- ERR_INTERRUPTED# -> Interrupted
- ERR_INVALIDARGUMENT# -> InvalidArgument
- ERR_NOSUCHTHING# -> NoSuchThing
- ERR_OTHERERROR# -> OtherError
- ERR_PERMISSIONDENIED# -> PermissionDenied
- ERR_PROTOCOLERROR# -> ProtocolError
- ERR_RESOURCEBUSY# -> ResourceBusy
- ERR_RESOURCEEXHAUSTED# -> ResourceExhausted
- ERR_RESOURCEVANISHED# -> ResourceVanished
- ERR_SYSTEMERROR# -> SystemError
- ERR_TIMEEXPIRED# -> TimeExpired
- ERR_UNSATISFIEDCONSTRAINTS# -> UnsatisfiedConstraints
- ERR_UNSUPPORTEDOPERATION# -> UnsupportedOperation
- ERR_EOF# -> EOF
- _ -> OtherError
-
- msg =
- call_site ++ ':' : ' ' : unpackCString str ++
- (case iot of
- OtherError -> "(error code: " ++ show (I# errtype#) ++ ")"
- _ -> "") ++
- (case reason of
- Nothing -> ""
- Just m -> ' ':m)
- in
- return (IOError Nothing iot msg)
-\end{code}
+writeIORef :: IORef a -> a -> IO ()
+writeIORef (IORef var) v = stToIO (writeSTRef var v)
-%*********************************************************
-%* *
-\subsection{Types @Handle@, @Handle__@}
-%* *
-%*********************************************************
+modifyIORef :: IORef a -> (a -> a) -> IO ()
+modifyIORef ref f = readIORef ref >>= \x -> writeIORef ref (f x)
-The type for @Handle@ is defined rather than in @IOHandle@
-module, as the @IOError@ type uses it..all operations over
-a handles reside in @IOHandle@.
+-- deprecated, use modifyIORef
+updateIORef :: IORef a -> (a -> a) -> IO ()
+updateIORef = modifyIORef
-\begin{code}
+-- ---------------------------------------------------------------------------
+-- Show instance for Handles
-{-
- Sigh, the MVar ops in ConcBase depend on IO, the IO
- representation here depend on MVars for handles (when
- compiling a concurrent way). Break the cycle by having
- the definition of MVars go here:
+-- handle types are 'show'n when printing error msgs, so
+-- we provide a more user-friendly Show instance for it
+-- than the derived one.
--}
-data MVar a = MVar (SynchVar# RealWorld a)
+instance Show HandleType where
+ showsPrec p t =
+ case t of
+ ClosedHandle -> showString "closed"
+ SemiClosedHandle -> showString "semi-closed"
+ ReadHandle -> showString "readable"
+ WriteHandle -> showString "writable"
+ AppendHandle -> showString "writable (append)"
+ ReadWriteHandle -> showString "read-writable"
+ ReadSideHandle _ -> showString "read-writable (duplex)"
-{-
- Double sigh - ForeignObj is needed here too to break a cycle.
--}
-data ForeignObj = ForeignObj ForeignObj# -- another one
+instance Show Handle where
+ showsPrec p (FileHandle h) = showHandle p h
+ showsPrec p (DuplexHandle h _) = showHandle p h
+
+showHandle p h =
+ let
+ -- (Big) SIGH: unfolded defn of takeMVar to avoid
+ -- an (oh-so) unfortunate module loop with PrelConc.
+ hdl_ = unsafePerformIO (IO $ \ s# ->
+ case h of { MVar h# ->
+ case takeMVar# h# s# of { (# s2# , r #) ->
+ case putMVar# h# r s2# of { s3# ->
+ (# s3#, r #) }}})
+ in
+ showChar '{' .
+ showHdl (haType hdl_)
+ (showString "loc=" . showString (haFilePath hdl_) . showChar ',' .
+ showString "type=" . showsPrec p (haType hdl_) . showChar ',' .
+ showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
+ where
+ showHdl :: HandleType -> ShowS -> ShowS
+ showHdl ht cont =
+ case ht of
+ ClosedHandle -> showsPrec p ht . showString "}"
+ _ -> cont
+
+ showBufMode :: Buffer -> BufferMode -> ShowS
+ showBufMode buf bmo =
+ case bmo of
+ NoBuffering -> showString "none"
+ LineBuffering -> showString "line"
+ BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n)
+ BlockBuffering Nothing -> showString "block " . showParen True (showsPrec p def)
+ where
+ def :: Int
+ def = bufSize buf
+
+-- ------------------------------------------------------------------------
+-- Exception datatype and operations
+
+data Exception
+ = IOException IOException -- IO exceptions
+ | ArithException ArithException -- Arithmetic exceptions
+ | ArrayException ArrayException -- Array-related exceptions
+ | ErrorCall String -- Calls to 'error'
+ | NoMethodError String -- A non-existent method was invoked
+ | PatternMatchFail String -- A pattern match / guard failure
+ | RecSelError String -- Selecting a non-existent field
+ | RecConError String -- Field missing in record construction
+ | RecUpdError String -- Record doesn't contain updated field
+ | AssertionFailed String -- Assertions
+ | DynException Dynamic -- Dynamic exceptions
+ | AsyncException AsyncException -- Externally generated errors
+ | BlockedOnDeadMVar -- Blocking on a dead MVar
+ | NonTermination
+ | UserError String
+
+data ArithException
+ = Overflow
+ | Underflow
+ | LossOfPrecision
+ | DivideByZero
+ | Denormal
+ deriving (Eq, Ord)
+
+data AsyncException
+ = StackOverflow
+ | HeapOverflow
+ | ThreadKilled
+ deriving (Eq, Ord)
+
+data ArrayException
+ = IndexOutOfBounds String -- out-of-range array access
+ | UndefinedElement String -- evaluating an undefined element
+ deriving (Eq, Ord)
+
+stackOverflow, heapOverflow :: Exception -- for the RTS
+stackOverflow = AsyncException StackOverflow
+heapOverflow = AsyncException 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"
+
+instance Show ArrayException where
+ showsPrec _ (IndexOutOfBounds s)
+ = 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 _ (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 "unknown exception"
+ showsPrec _ (AsyncException e) = shows e
+ showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
+ showsPrec _ (NonTermination) = showString "<<loop>>"
+ showsPrec _ (UserError err) = showString err
+
+-- --------------------------------------------------------------------------
+-- Primitive throw
+
+throw :: Exception -> a
+throw exception = raise# exception
+
+ioError :: Exception -> IO a
+ioError err = IO $ \s -> throw err s
+
+ioException :: IOException -> IO a
+ioException err = IO $ \s -> throw (IOException err) s
+
+-- ---------------------------------------------------------------------------
+-- IOError type
+
+-- A value @IOError@ encode errors occurred in the @IO@ monad.
+-- An @IOError@ records a more specific error type, a descriptive
+-- string and maybe the handle that was used when the error was
+-- flagged.
+
+type IOError = Exception
+
+data IOException
+ = IOError
+ (Maybe Handle) -- the handle used by the action flagging the
+ -- the error.
+ IOErrorType -- what it was.
+ String -- location.
+ String -- error type specific information.
+ (Maybe FilePath) -- filename the error is related to.
+
+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
-#if defined(__CONCURRENT_HASKELL__)
-newtype Handle = Handle (MVar Handle__)
-#else
-newtype Handle = Handle (MutableVar RealWorld Handle__)
+data IOErrorType
+ = AlreadyExists | HardwareFault
+ | IllegalOperation | InappropriateType
+ | Interrupted | InvalidArgument
+ | NoSuchThing | OtherError
+ | PermissionDenied | ProtocolError
+ | ResourceBusy | ResourceExhausted
+ | ResourceVanished | SystemError
+ | TimeExpired | UnsatisfiedConstraints
+ | UnsupportedOperation
+ | EOF
+#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
+ | ComError Int -- HRESULT
#endif
-
-data Handle__
- = ErrorHandle IOError
- | ClosedHandle
-#ifndef __PARALLEL_HASKELL__
- | SemiClosedHandle ForeignObj (Addr, Int)
- | ReadHandle ForeignObj (Maybe BufferMode) Bool
- | WriteHandle ForeignObj (Maybe BufferMode) Bool
- | AppendHandle ForeignObj (Maybe BufferMode) Bool
- | ReadWriteHandle ForeignObj (Maybe BufferMode) Bool
-#else
- | SemiClosedHandle Addr (Addr, Int)
- | ReadHandle Addr (Maybe BufferMode) Bool
- | WriteHandle Addr (Maybe BufferMode) Bool
- | AppendHandle Addr (Maybe BufferMode) Bool
- | ReadWriteHandle Addr (Maybe BufferMode) Bool
+ deriving (Eq)
+
+instance Show IOErrorType where
+ showsPrec _ e =
+ showString $
+ case e of
+ AlreadyExists -> "already exists"
+ HardwareFault -> "hardware fault"
+ IllegalOperation -> "illegal operation"
+ InappropriateType -> "inappropriate type"
+ Interrupted -> "interrupted"
+ InvalidArgument -> "invalid argument"
+ NoSuchThing -> "does not exist"
+ OtherError -> "failed"
+ PermissionDenied -> "permission denied"
+ ProtocolError -> "protocol error"
+ ResourceBusy -> "resource busy"
+ ResourceExhausted -> "resource exhausted"
+ ResourceVanished -> "resource vanished"
+ SystemError -> "system error"
+ TimeExpired -> "timeout"
+ UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
+ UnsupportedOperation -> "unsupported operation"
+ EOF -> "end of file"
+#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
+ ComError _ -> "COM error"
#endif
--- Standard Instances as defined by the Report..
--- instance Eq Handle (defined in IO)
--- instance Show Handle ""
-\end{code}
-
-%*********************************************************
-%* *
-\subsection[BufferMode]{Buffering modes}
-%* *
-%*********************************************************
-
-Three kinds of buffering are supported: line-buffering,
-block-buffering or no-buffering. These modes have the following
-effects. For output, items are written out from the internal
-buffer according to the buffer mode:
-
-\begin{itemize}
-\item[line-buffering] the entire output buffer is written
-out whenever a newline is output, the output buffer overflows,
-a flush is issued, or the handle is closed.
-
-\item[block-buffering] the entire output buffer is written out whenever
-it overflows, a flush is issued, or the handle
-is closed.
-
-\item[no-buffering] output is written immediately, and never stored
-in the output buffer.
-\end{itemize}
-
-The output buffer is emptied as soon as it has been written out.
-
-Similarly, input occurs according to the buffer mode for handle {\em hdl}.
-\begin{itemize}
-\item[line-buffering] when the input buffer for {\em hdl} is not empty,
-the next item is obtained from the buffer;
-otherwise, when the input buffer is empty,
-characters up to and including the next newline
-character are read into the buffer. No characters
-are available until the newline character is
-available.
-\item[block-buffering] when the input buffer for {\em hdl} becomes empty,
-the next block of data is read into this buffer.
-\item[no-buffering] the next input item is read and returned.
-\end{itemize}
-For most implementations, physical files will normally be block-buffered
-and terminals will normally be line-buffered.
-\begin{code}
-data BufferMode
- = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
- deriving (Eq, Ord, Show)
- {- Read instance defined in IO. -}
-
-\end{code}
-
-\begin{code}
-performGC :: IO ()
-performGC = _ccall_GC_ StgPerformGarbageCollection
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Unsafe @IO@ operations}
-%* *
-%*********************************************************
-
-\begin{code}
-{-# NOINLINE unsafePerformIO #-}
-unsafePerformIO :: IO a -> a
-unsafePerformIO (IO m)
- = case m realWorld# of
- IOok _ r -> r
- IOfail _ e -> error ("unsafePerformIO: I/O error: " ++ show e ++ "\n")
-
-{-# NOINLINE unsafeInterleaveIO #-}
-unsafeInterleaveIO :: IO a -> IO a
-unsafeInterleaveIO (IO m) = IO ( \ s ->
- let
- IOok _ r = m s
- in
- IOok s r)
-
-{-# NOINLINE trace #-}
-trace :: String -> a -> a
-trace string expr
- = unsafePerformIO (
- ((_ccall_ PreTraceHook sTDERR{-msg-}):: IO ()) >>
- fputs sTDERR string >>
- ((_ccall_ PostTraceHook sTDERR{-msg-}):: IO ()) >>
- return expr )
- where
- sTDERR = (``stderr'' :: Addr)
+userError :: String -> IOError
+userError str = UserError str
+
+-- ---------------------------------------------------------------------------
+-- Predicates on IOError
+
+isAlreadyExistsError :: IOError -> Bool
+isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True
+isAlreadyExistsError _ = False
+
+isAlreadyInUseError :: IOError -> Bool
+isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True
+isAlreadyInUseError _ = False
+
+isFullError :: IOError -> Bool
+isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True
+isFullError _ = False
+
+isEOFError :: IOError -> Bool
+isEOFError (IOException (IOError _ EOF _ _ _)) = True
+isEOFError _ = False
+
+isIllegalOperation :: IOError -> Bool
+isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True
+isIllegalOperation _ = False
+
+isPermissionError :: IOError -> Bool
+isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True
+isPermissionError _ = False
+
+isDoesNotExistError :: IOError -> Bool
+isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True
+isDoesNotExistError _ = False
+
+isUserError :: IOError -> Bool
+isUserError (UserError _) = True
+isUserError _ = False
+
+-- ---------------------------------------------------------------------------
+-- Showing IOErrors
+
+instance Show IOException where
+ showsPrec p (IOError hdl iot loc s fn) =
+ showsPrec p iot .
+ (case loc of
+ "" -> id
+ _ -> showString "\nAction: " . showString loc) .
+ (case hdl of
+ Nothing -> id
+ Just h -> showString "\nHandle: " . showsPrec p h) .
+ (case s of
+ "" -> id
+ _ -> showString "\nReason: " . showString s) .
+ (case fn of
+ Nothing -> id
+ Just name -> showString "\nFile: " . showString name)
\end{code}
projects / ghc-hetmet.git / blobdiff