X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelIOBase.lhs;h=ef862df2b0ebc7adc029b8e735eb8d7d10f26607;hb=26e1d2d10d8831a6a1d711ae096824cddcd29145;hp=6ef3f277ce8f9b26501b737bc1df369f7130957c;hpb=d1430fb505037999e8961fbd7e922d0e82eca0f1;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index 6ef3f27..ef862df 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -1,59 +1,30 @@ % ------------------------------------------------------------------------------ -% $Id: PrelIOBase.lhs,v 1.33 2001/02/06 11:42:30 simonmar Exp $ +% $Id: PrelIOBase.lhs,v 1.45 2001/11/26 20:04:00 sof Exp $ % -% (c) The University of Glasgow, 1994-2000 +% (c) The University of Glasgow, 1994-2001 % -\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 "cbits/stgio.h" #-} -#include "config.h" -#include "cbits/stgerror.h" - -#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */ +{-# OPTIONS -fno-implicit-prelude #-} module PrelIOBase where -import {-# SOURCE #-} PrelErr ( error ) - import PrelST +import PrelArr import PrelBase -import PrelNum ( fromInteger ) -- Integer literals +import PrelNum -- To get fromInteger etc, needed because of -fno-implicit-prelude import PrelMaybe ( Maybe(..) ) import PrelShow import PrelList +import PrelRead import PrelDynamic -import PrelPtr -import PrelPack ( unpackCString ) - -#if !defined(__CONCURRENT_HASKELL__) -import PrelArr ( MutableVar, readVar ) -#endif -#endif - -#ifdef __HUGS__ -#define __CONCURRENT_HASKELL__ -#define stToIO id -#define unpackCString primUnpackString -#endif - -#ifndef __PARALLEL_HASKELL__ -#define FILE_OBJECT (ForeignPtr ()) -#else -#define FILE_OBJECT (Ptr ()) - -#endif -\end{code} -%********************************************************* -%* * -\subsection{The @IO@ monad} -%* * -%********************************************************* +-- --------------------------------------------------------------------------- +-- 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. @@ -74,9 +45,8 @@ Prelude - PrelIOBase.lhs, and several other places including Libraries - parts of hslibs/lang. --SDM +-} -\begin{code} -#ifndef __HUGS__ newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) @@ -93,7 +63,10 @@ instance Monad IO where return x = returnIO x m >>= k = bindIO m k - fail s = ioError (userError s) + fail s = failIO s + +failIO :: String -> IO a +failIO s = ioError (userError s) liftIO :: IO a -> State# RealWorld -> STret RealWorld a liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r @@ -106,125 +79,157 @@ bindIO (IO m) k = IO ( \ s -> returnIO :: a -> IO a returnIO x = IO (\ s -> (# s, x #)) -#endif -\end{code} -%********************************************************* -%* * -\subsection{Coercions to @ST@} -%* * -%********************************************************* +-- --------------------------------------------------------------------------- +-- Coercions between IO and ST -\begin{code} -#ifdef __HUGS__ -/* Hugs doesn't distinguish these types so no coercion required) */ -#else +--stToIO :: (forall s. ST s a) -> IO a stToIO :: ST RealWorld a -> IO a -stToIO (ST m) = (IO m) +stToIO (ST m) = IO m ioToST :: IO a -> ST RealWorld a ioToST (IO m) = (ST m) -#endif -\end{code} -%********************************************************* -%* * -\subsection{Unsafe @IO@ operations} -%* * -%********************************************************* +-- --------------------------------------------------------------------------- +-- Unsafe IO operations -\begin{code} -#ifndef __HUGS__ {-# NOINLINE unsafePerformIO #-} unsafePerformIO :: IO a -> a unsafePerformIO (IO m) = case m realWorld# of (# _, r #) -> r +{-# NOINLINE unsafeInterleaveIO #-} unsafeInterleaveIO :: IO a -> IO a -unsafeInterleaveIO = stToIO . unsafeInterleaveST . ioToST -#endif -\end{code} - -%********************************************************* -%* * -\subsection{Types @Handle@, @Handle__@} -%* * -%********************************************************* - -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@. +unsafeInterleaveIO (IO m) + = IO ( \ s -> let + r = case m s of (# _, res #) -> res + in + (# s, r #)) -\begin{code} - -#ifndef __HUGS__ -{- - Sigh, the MVar ops in ConcBase depend on IO, the IO - representation here depend on MVars for handles (when - compiling in a concurrent way). Break the cycle by having - the definition of MVars go here: +-- --------------------------------------------------------------------------- +-- Handle type --} data MVar a = MVar (MVar# RealWorld a) -- 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# -{- - Double sigh - ForeignPtr is needed here too to break a cycle. --} -data ForeignPtr a = ForeignPtr ForeignObj# -instance CCallable (ForeignPtr a) +-- 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: -eqForeignPtr :: ForeignPtr a -> ForeignPtr a -> Bool -eqForeignPtr mp1 mp2 - = unsafePerformIO (primEqForeignPtr mp1 mp2) /= (0::Int) +-- * 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) -foreign import "eqForeignObj" unsafe - primEqForeignPtr :: ForeignPtr a -> ForeignPtr a -> IO Int +-- 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. -instance Eq (ForeignPtr a) where - p == q = eqForeignPtr p q - p /= q = not (eqForeignPtr p q) -#endif /* ndef __HUGS__ */ +data Handle + = FileHandle -- A normal handle to a file + !(MVar Handle__) -#if defined(__CONCURRENT_HASKELL__) -newtype Handle = Handle (MVar Handle__) -#else -newtype Handle = Handle (MutableVar RealWorld Handle__) -#endif + | DuplexHandle -- A handle to a read/write stream + !(MVar Handle__) -- The read side + !(MVar Handle__) -- The write side + +-- NOTES: +-- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be +-- seekable. instance Eq Handle where - (Handle h1) == (Handle h2) = h1 == h2 + (FileHandle h1) == (FileHandle h2) = h1 == h2 + (DuplexHandle h1 _) == (DuplexHandle h2 _) = h1 == h2 + _ == _ = False + +type FD = Int -- XXX ToDo: should be CInt -{- - 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: - - * type (read,write,closed etc.) - * pointer to the external file object. - * buffering mode - * user-friendly name (usually the - 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. --} data Handle__ = Handle__ { - haFO__ :: FILE_OBJECT, - haType__ :: Handle__Type, - haBufferMode__ :: BufferMode, - haFilePath__ :: FilePath, - haBuffers__ :: [Ptr ()] + haFD :: !FD, -- file descriptor + haType :: HandleType, -- type (read/write/append etc.) + haIsBin :: Bool, -- binary mode? + haIsStream :: Bool, -- is this a stream handle? + haBufferMode :: BufferMode, -- buffer contains read/write data? + haFilePath :: FilePath, -- file name, possibly + haBuffer :: !(IORef Buffer), -- the current buffer + haBuffers :: !(IORef BufferList), -- spare buffers + haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a + -- duplex handle. } -{- - Internally, we classify handles as being one - of the following: --} -data Handle__Type +-- --------------------------------------------------------------------------- +-- 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 + +-- 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 @@ -232,40 +237,108 @@ data Handle__Type | AppendHandle | ReadWriteHandle +isReadableHandleType ReadHandle = True +isReadableHandleType ReadWriteHandle = True +isReadableHandleType _ = False + +isWritableHandleType AppendHandle = True +isWritableHandleType WriteHandle = True +isWritableHandleType ReadWriteHandle = True +isWritableHandleType _ = False -- File names are specified using @FilePath@, a OS-dependent -- string that (hopefully, I guess) maps to an accessible file/object. type FilePath = String -\end{code} -%********************************************************* -%* * -\subsection[Show-Handle]{Show instance for Handles} -%* * -%********************************************************* +-- --------------------------------------------------------------------------- +-- 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} --- handle types are 'show'ed when printing error msgs, so +data BufferMode + = NoBuffering | LineBuffering | BlockBuffering (Maybe Int) + deriving (Eq, Ord, Read, Show) + +-- --------------------------------------------------------------------------- +-- IORefs + +newtype IORef a = IORef (STRef RealWorld a) deriving Eq + +newIORef :: a -> IO (IORef a) +newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var) + +readIORef :: IORef a -> IO a +readIORef (IORef var) = stToIO (readSTRef var) + +writeIORef :: IORef a -> a -> IO () +writeIORef (IORef var) v = stToIO (writeSTRef var v) + +modifyIORef :: IORef a -> (a -> a) -> IO () +modifyIORef ref f = readIORef ref >>= \x -> writeIORef ref (f x) + +-- deprecated, use modifyIORef +updateIORef :: IORef a -> (a -> a) -> IO () +updateIORef = modifyIORef + +-- --------------------------------------------------------------------------- +-- Show instance for Handles + +-- handle types are 'show'n when printing error msgs, so -- we provide a more user-friendly Show instance for it -- than the derived one. -instance Show Handle__Type where + +instance Show HandleType where showsPrec p t = case t of ClosedHandle -> showString "closed" SemiClosedHandle -> showString "semi-closed" ReadHandle -> showString "readable" - WriteHandle -> showString "writeable" - AppendHandle -> showString "writeable (append)" - ReadWriteHandle -> showString "read-writeable" + WriteHandle -> showString "writable" + AppendHandle -> showString "writable (append)" + ReadWriteHandle -> showString "read-writable" instance Show Handle where - showsPrec p (Handle h) = + showsPrec p (FileHandle h) = showHandle p h False + showsPrec p (DuplexHandle _ h) = showHandle p h True + +showHandle p h duplex = let -#if defined(__CONCURRENT_HASKELL__) -#ifdef __HUGS__ - hdl_ = unsafePerformIO (primTakeMVar h) -#else -- (Big) SIGH: unfolded defn of takeMVar to avoid -- an (oh-so) unfortunate module loop with PrelConc. hdl_ = unsafePerformIO (IO $ \ s# -> @@ -273,25 +346,26 @@ instance Show Handle where case takeMVar# h# s# of { (# s2# , r #) -> case putMVar# h# r s2# of { s3# -> (# s3#, r #) }}}) -#endif -#else - hdl_ = unsafePerformIO (stToIO (readVar h)) -#endif + + showType | duplex = showString "duplex (read-write)" + | otherwise = showsPrec p (haType hdl_) in showChar '{' . - showHdl (haType__ hdl_) - (showString "loc=" . showString (haFilePath__ hdl_) . showChar ',' . - showString "type=" . showsPrec p (haType__ hdl_) . showChar ',' . - showString "buffering=" . showBufMode (haFO__ hdl_) (haBufferMode__ hdl_) . showString "}\n" ) + showHdl (haType hdl_) + (showString "loc=" . showString (haFilePath hdl_) . showChar ',' . + showString "type=" . showType . showChar ',' . + showString "binary=" . showsPrec p (haIsBin hdl_) . showChar ',' . + showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" ) where - showHdl :: Handle__Type -> ShowS -> ShowS + + showHdl :: HandleType -> ShowS -> ShowS showHdl ht cont = case ht of - ClosedHandle -> showsPrec p ht . showString "}\n" + ClosedHandle -> showsPrec p ht . showString "}" _ -> cont - showBufMode :: FILE_OBJECT -> BufferMode -> ShowS - showBufMode fo bmo = + showBufMode :: Buffer -> BufferMode -> ShowS + showBufMode buf bmo = case bmo of NoBuffering -> showString "none" LineBuffering -> showString "line" @@ -299,98 +373,17 @@ instance Show Handle where BlockBuffering Nothing -> showString "block " . showParen True (showsPrec p def) where def :: Int - def = unsafePerformIO (getBufSize fo) -\end{code} + def = bufSize buf -%********************************************************* -%* * -\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. (the IO interface provides -operations for changing the default buffering of a handle tho.) +-- ------------------------------------------------------------------------ +-- Exception datatype and operations -\begin{code} -data BufferMode - = NoBuffering | LineBuffering | BlockBuffering (Maybe Int) - deriving (Eq, Ord, Show) - {- Read instance defined in IO. -} - -\end{code} - -Foreign import declarations to helper routines: - -\begin{code} -foreign import "libHS_cbits" "getErrStr__" unsafe getErrStr__ :: IO (Ptr ()) -foreign import "libHS_cbits" "getErrNo__" unsafe getErrNo__ :: IO Int -foreign import "libHS_cbits" "getErrType__" unsafe getErrType__ :: IO Int - --- ToDo: use mallocBytes from PrelMarshal? -malloc :: Int -> IO (Ptr ()) -malloc sz = do - a <- _malloc sz - if (a == nullPtr) - then ioException (IOError Nothing ResourceExhausted - "malloc" "out of memory" Nothing) - else return a - -foreign import "malloc" unsafe _malloc :: Int -> IO (Ptr ()) - -foreign import "libHS_cbits" "getBufSize" unsafe - getBufSize :: FILE_OBJECT -> IO Int -foreign import "libHS_cbits" "setBuf" unsafe - setBuf :: FILE_OBJECT -> Ptr () -> Int -> IO () - -\end{code} - -%********************************************************* -%* * -\subsection{Exception datatype and operations} -%* * -%********************************************************* - -\begin{code} data Exception = IOException IOException -- IO exceptions | ArithException ArithException -- Arithmetic exceptions | ArrayException ArrayException -- Array-related exceptions | ErrorCall String -- Calls to 'error' + | ExitException ExitCode -- Call to System.exitWith | NoMethodError String -- A non-existent method was invoked | PatternMatchFail String -- A pattern match / guard failure | RecSelError String -- Selecting a non-existent field @@ -399,7 +392,6 @@ data Exception | AssertionFailed String -- Assertions | DynException Dynamic -- Dynamic exceptions | AsyncException AsyncException -- Externally generated errors - | PutFullMVar -- Put on a full MVar | BlockedOnDeadMVar -- Blocking on a dead MVar | NonTermination | UserError String @@ -454,6 +446,7 @@ instance Show Exception where 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 @@ -462,19 +455,29 @@ instance Show Exception where showsPrec _ (AssertionFailed err) = showString err showsPrec _ (DynException _err) = showString "unknown exception" showsPrec _ (AsyncException e) = shows e - showsPrec _ (PutFullMVar) = showString "putMVar: full MVar" showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely" showsPrec _ (NonTermination) = showString "<>" showsPrec _ (UserError err) = showString err -\end{code} -%********************************************************* -%* * -\subsection{Primitive throw} -%* * -%********************************************************* +-- ----------------------------------------------------------------------------- +-- The ExitCode type + +-- The `ExitCode' type defines the exit codes that a program +-- can return. `ExitSuccess' indicates successful termination; +-- and `ExitFailure code' indicates program failure +-- with value `code'. The exact interpretation of `code' +-- is operating-system dependent. In particular, some values of +-- `code' may be prohibited (e.g. 0 on a POSIX-compliant system). + +-- We need it here because it is used in ExitException in the +-- Exception datatype (above). + +data ExitCode = ExitSuccess | ExitFailure Int + deriving (Eq, Ord, Read, Show) + +-- -------------------------------------------------------------------------- +-- Primitive throw -\begin{code} throw :: Exception -> a throw exception = raise# exception @@ -483,20 +486,15 @@ ioError err = IO $ \s -> throw err s ioException :: IOException -> IO a ioException err = IO $ \s -> throw (IOException err) s -\end{code} -%********************************************************* -%* * -\subsection{Type @IOError@} -%* * -%********************************************************* +-- --------------------------------------------------------------------------- +-- 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. +-- 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. -\begin{code} type IOError = Exception data IOException @@ -523,10 +521,13 @@ data IOErrorType | TimeExpired | UnsatisfiedConstraints | UnsupportedOperation | EOF -#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS) - | ComError Int -- HRESULT -#endif - deriving (Eq) + | 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 instance Show IOErrorType where showsPrec _ e = @@ -550,19 +551,13 @@ instance Show IOErrorType where 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 - - + DynIOError{} -> "unknown IO error" userError :: String -> IOError userError str = UserError str -\end{code} -Predicates on IOError; little effort made on these so far... - -\begin{code} +-- --------------------------------------------------------------------------- +-- Predicates on IOError isAlreadyExistsError :: IOError -> Bool isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True @@ -595,108 +590,23 @@ isDoesNotExistError _ = False isUserError :: IOError -> Bool isUserError (UserError _) = True isUserError _ = False -\end{code} -Showing @IOError@s +-- --------------------------------------------------------------------------- +-- Showing IOErrors -\begin{code} -#ifdef __HUGS__ --- For now we give a fairly uninformative error message which just happens to --- be like the ones that Hugs used to give. -instance Show IOException where - showsPrec p (IOError _ _ _ s _) = showString s . showChar '\n' -#else instance Show IOException where showsPrec p (IOError hdl iot loc s fn) = showsPrec p iot . (case loc of "" -> id _ -> showString "\nAction: " . showString loc) . - showHdl . + (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) - where - showHdl = - case hdl of - Nothing -> id - Just h -> showString "\nHandle: " . showsPrec p h - -#endif -\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. - -\begin{code} -constructErrorAndFail :: String -> IO a -constructErrorAndFail call_site - = constructError call_site >>= \ io_error -> - ioError (IOException io_error) - -constructErrorAndFailWithInfo :: String -> String -> IO a -constructErrorAndFailWithInfo call_site fn - = constructErrorMsg call_site (Just fn) >>= \ io_error -> - ioError (IOException io_error) - -\end{code} - -This doesn't seem to be documented/spelled out anywhere, -so here goes: (SOF) - -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. Error constructing functions will then reach out -and grab these values when generating - -\begin{code} -constructError :: String -> IO IOException -constructError call_site = constructErrorMsg call_site Nothing - -constructErrorMsg :: String -> Maybe String -> IO IOException -constructErrorMsg call_site fn = - getErrType__ >>= \ errtype -> - getErrStr__ >>= \ str -> - let - iot = - case (errtype::Int) 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 = - unpackCString str ++ - (case iot of - OtherError -> "(error code: " ++ show errtype ++ ")" - _ -> "") - in - return (IOError Nothing iot call_site msg fn) \end{code}