X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelIOBase.lhs;h=51a16dc16faaec958bafe5b0bce5f33bbb29c7bc;hb=239e9471e104fd88ec93bf42623c3a68a496657a;hp=2e43613234ca44deb21f318048264bd29f3e08d5;hpb=d392968d909449a16d02e0e70a5eb9eddb1c07ab;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index 2e43613..51a16dc 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -1,67 +1,52 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelIOBase.lhs,v 1.12 1999/08/23 12:53:25 keithw Exp $ +% ------------------------------------------------------------------------------ +% $Id: PrelIOBase.lhs,v 1.47 2002/01/29 17:12:53 simonmar Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1998 +% (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 "cbits/error.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 {-# SOURCE #-} PrelException ( ioError ) -import PrelST ( ST(..), STret(..) ) +import PrelNum -- To get fromInteger etc, needed because of -fno-implicit-prelude import PrelMaybe ( Maybe(..) ) -import PrelAddr ( Addr(..), nullAddr ) -import PrelPack ( unpackCString ) import PrelShow +import PrelList +import PrelRead +import PrelDynamic -#if !defined(__CONCURRENT_HASKELL__) -import PrelArr ( MutableVar, readVar ) -#endif -#endif - -#ifdef __HUGS__ -#define cat2(x,y) x/**/y -#define CCALL(fun) cat2(prim_,fun) -#define __CONCURRENT_HASKELL__ -#define stToIO id -#define unpackCString primUnpackString -#else -#define CCALL(fun) _ccall_ fun -#define ref_freeStdFileObject (``&freeStdFileObject''::Addr) -#endif - -#ifndef __PARALLEL_HASKELL__ -#define FILE_OBJECT ForeignObj -#else -#define FILE_OBJECT Addr -#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. -\begin{code} -#ifndef __HUGS__ +NOTE: The IO representation is deeply wired in to various parts of the +system. The following list may or may not be exhaustive: + +Compiler - types of various primitives in PrimOp.lhs + +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. + +Libraries - parts of hslibs/lang. + +--SDM +-} + newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) @@ -75,14 +60,13 @@ instance Monad IO where {-# INLINE (>>) #-} {-# INLINE (>>=) #-} m >> k = m >>= \ _ -> k - return x = IO $ \ s -> (# s, x #) + return x = returnIO x m >>= k = bindIO m k - fail s = error s -- not ioError? + fail s = failIO s - -- not required but worth having around -fixIO :: (a -> IO a) -> IO a -fixIO m = stToIO (fixST (ioToST . m)) +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 @@ -93,64 +77,459 @@ bindIO (IO m) k = IO ( \ s -> (# new_s, a #) -> unIO (k a) new_s ) -#endif -\end{code} +returnIO :: a -> IO a +returnIO x = IO (\ s -> (# s, x #)) -%********************************************************* -%* * -\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} +unsafeInterleaveIO (IO m) + = IO ( \ s -> let + r = case m s of (# _, res #) -> res + in + (# s, r #)) -%********************************************************* -%* * -\subsection{Type @IOError@} -%* * -%********************************************************* +-- --------------------------------------------------------------------------- +-- Handle 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. +data MVar a = MVar (MVar# RealWorld a) -\begin{code} -data IOError - = IOError - (Maybe Handle) -- the handle used by the action flagging the - -- the error. - IOErrorType -- what it was. - String -- location - String -- error type specific information. +-- 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# + +-- 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.) +-- * the underlying file descriptor +-- * buffering mode +-- * buffer, and spare buffers +-- * 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 + = FileHandle -- A normal handle to a file + !(MVar Handle__) + + | 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 + (FileHandle h1) == (FileHandle h2) = h1 == h2 + (DuplexHandle h1 _) == (DuplexHandle h2 _) = h1 == h2 + _ == _ = False + +type FD = Int -- XXX ToDo: should be CInt + +data Handle__ + = Handle__ { + 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. + } + +-- --------------------------------------------------------------------------- +-- 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 + | WriteHandle + | 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 + +-- --------------------------------------------------------------------------- +-- 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.) + +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 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" + +instance Show Handle where + showsPrec p (FileHandle h) = showHandle p h False + showsPrec p (DuplexHandle _ h) = showHandle p h True + +showHandle p h duplex = + 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 #) }}}) + showType | duplex = showString "duplex (read-write)" + | otherwise = showsPrec p (haType hdl_) + in + showChar '{' . + 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 :: 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' + | 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 + | 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 -- Cyclic data dependency or other loop + | Deadlock -- no threads can run (raised in main thread) + | 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 _ (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 "unknown exception" + showsPrec _ (AsyncException e) = shows e + showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely" + showsPrec _ (NonTermination) = showString "<>" + showsPrec _ (Deadlock) = showString "<>" + showsPrec _ (UserError err) = showString err + +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 + Deadlock == Deadlock = True + UserError e1 == UserError e2 = e1 == e2 + +-- ----------------------------------------------------------------------------- +-- 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 + +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 data IOErrorType = AlreadyExists | HardwareFault @@ -161,12 +540,15 @@ data IOErrorType | ResourceBusy | ResourceExhausted | ResourceVanished | SystemError | TimeExpired | UnsatisfiedConstraints - | UnsupportedOperation | UserError + | UnsupportedOperation | EOF -#ifdef _WIN32 - | 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 = @@ -188,358 +570,64 @@ instance Show IOErrorType where SystemError -> "system error" TimeExpired -> "timeout" UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise! - UserError -> "failed" UnsupportedOperation -> "unsupported operation" EOF -> "end of file" -#ifdef _WIN32 - ComError _ -> "COM error" -#endif - - + DynIOError{} -> "unknown IO error" userError :: String -> IOError -userError str = IOError Nothing UserError "" str -\end{code} +userError str = UserError str -Predicates on IOError; little effort made on these so far... - -\begin{code} +-- --------------------------------------------------------------------------- +-- Predicates on IOError isAlreadyExistsError :: IOError -> Bool -isAlreadyExistsError (IOError _ AlreadyExists _ _) = True -isAlreadyExistsError _ = False +isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True +isAlreadyExistsError _ = False isAlreadyInUseError :: IOError -> Bool -isAlreadyInUseError (IOError _ ResourceBusy _ _) = True -isAlreadyInUseError _ = False +isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True +isAlreadyInUseError _ = False isFullError :: IOError -> Bool -isFullError (IOError _ ResourceExhausted _ _) = True -isFullError _ = False +isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True +isFullError _ = False isEOFError :: IOError -> Bool -isEOFError (IOError _ EOF _ _) = True -isEOFError _ = False +isEOFError (IOException (IOError _ EOF _ _ _)) = True +isEOFError _ = False isIllegalOperation :: IOError -> Bool -isIllegalOperation (IOError _ IllegalOperation _ _) = True -isIllegalOperation _ = False +isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True +isIllegalOperation _ = False isPermissionError :: IOError -> Bool -isPermissionError (IOError _ PermissionDenied _ _) = True -isPermissionError _ = False +isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True +isPermissionError _ = False isDoesNotExistError :: IOError -> Bool -isDoesNotExistError (IOError _ NoSuchThing _ _) = True -isDoesNotExistError _ = False +isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True +isDoesNotExistError _ = False isUserError :: IOError -> Bool -isUserError (IOError _ UserError _ _) = True -isUserError _ = False -\end{code} +isUserError (UserError _) = True +isUserError _ = False -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 IOError where - showsPrec p (IOError hdl iot loc s) = showString s . showChar '\n' -#else -instance Show IOError where - showsPrec p (IOError hdl iot loc s) = +instance Show IOException where + showsPrec p (IOError hdl iot loc s fn) = showsPrec p iot . - showChar '\n' . (case loc of "" -> id - _ -> showString "Action: " . showString loc . showChar '\n') . - showHdl . + _ -> showString "\nAction: " . showString loc) . + (case hdl of + Nothing -> id + Just h -> showString "\nHandle: " . showsPrec p h) . (case s of "" -> id - _ -> showString "Reason: " . showString s) - where - showHdl = - case hdl of - Nothing -> id - Just h -> showString "Handle: " . 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 io_error - -constructErrorAndFailWithInfo :: String -> String -> IO a -constructErrorAndFailWithInfo call_site reason - = constructErrorMsg call_site (Just reason) >>= \ io_error -> - ioError 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 IOError -constructError call_site = constructErrorMsg call_site Nothing - -constructErrorMsg :: String -> Maybe String -> IO IOError -constructErrorMsg call_site reason = - CCALL(getErrType__) >>= \ errtype -> - CCALL(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 ++ ")" - _ -> "") ++ - (case reason of - Nothing -> "" - Just m -> ' ':m) - in - return (IOError Nothing iot call_site msg) -\end{code} - -File names are specified using @FilePath@, a OS-dependent -string that (hopefully, I guess) maps to an accessible file/object. - -\begin{code} -type FilePath = String -\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@. - -\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: - --} -data MVar a = MVar (MVar# RealWorld a) - -{- - Double sigh - ForeignObj is needed here too to break a cycle. --} -data ForeignObj = ForeignObj ForeignObj# -- another one -instance CCallable ForeignObj -instance CCallable ForeignObj# -#endif /* ndef __HUGS__ */ - -#if defined(__CONCURRENT_HASKELL__) -newtype Handle = Handle (MVar Handle__) -#else -newtype Handle = Handle (MutableVar RealWorld Handle__) -#endif - -{- - 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 - } - -{- - Internally, we classify handles as being one - of the following: --} -data Handle__Type - = ErrorHandle IOError - | ClosedHandle - | SemiClosedHandle - | ReadHandle - | WriteHandle - | AppendHandle - | ReadWriteHandle - - --- handle types are 'show'ed when printing error msgs, so --- we provide a more user-friendly Show instance for it --- than the derived one. -instance Show Handle__Type where - showsPrec p t = - case t of - ErrorHandle iot -> showString "error " . showsPrec p iot - ClosedHandle -> showString "closed" - SemiClosedHandle -> showString "semi-closed" - ReadHandle -> showString "readable" - WriteHandle -> showString "writeable" - AppendHandle -> showString "writeable (append)" - ReadWriteHandle -> showString "read-writeable" - -instance Show Handle where - showsPrec p (Handle h) = - 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# -> - case h of { MVar h# -> - case takeMVar# h# s# of { (# s2# , r #) -> - (# s2#, r #) }}) -#endif -#else - hdl_ = unsafePerformIO (stToIO (readVar h)) -#endif - 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" ) - where - showHdl :: Handle__Type -> ShowS -> ShowS - showHdl ht cont = - case ht of - ClosedHandle -> showsPrec p ht . showString "}\n" - ErrorHandle _ -> showsPrec p ht . showString "}\n" - _ -> cont - - showBufMode :: FILE_OBJECT -> BufferMode -> ShowS - showBufMode fo 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 = unsafePerformIO (CCALL(getBufSize) fo) - -mkBuffer__ :: FILE_OBJECT -> Int -> IO () -mkBuffer__ fo sz_in_bytes = do - chunk <- - case sz_in_bytes of - 0 -> return nullAddr -- this has the effect of overwriting the pointer to the old buffer. - _ -> do - chunk <- CCALL(allocMemory__) sz_in_bytes - if chunk == nullAddr - then ioError (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory") - else return chunk - CCALL(setBuf) fo chunk sz_in_bytes - -\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. (the IO interface provides -operations for changing the default buffering of a handle tho.) - -\begin{code} -data BufferMode - = NoBuffering | LineBuffering | BlockBuffering (Maybe Int) - deriving (Eq, Ord, Show) - {- Read instance defined in IO. -} - + _ -> showString "\nReason: " . showString s) . + (case fn of + Nothing -> id + Just name -> showString "\nFile: " . showString name) \end{code}