\section[IO]{Module @IO@}
\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
module IO (
Handle, HandlePosn,
SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
stdin, stdout, stderr,
- openFile, hClose, hFileSize, hIsEOF, isEOF,
- hSetBuffering, hGetBuffering, hFlush, hGetPosn, hSetPosn, hSeek,
- hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable, hReady,
- hGetChar, hLookAhead, hGetContents, hPutChar, hPutStr, hPrint,
- isAlreadyExistsError, isAlreadyInUseError, isFullError, isEOFError,
+ openFile, hClose,
+ hFileSize, hIsEOF, isEOF,
+ hSetBuffering, hGetBuffering, hFlush,
+ hGetPosn, hSetPosn, hSeek,
+ hWaitForInput, hReady, hGetChar, hGetLine, hLookAhead, hGetContents,
+ hPutChar, hPutStr, hPutStrLn, hPrint,
+ hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable,
+
+ isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError,
+ isFullError, isEOFError,
isIllegalOperation, isPermissionError, isUserError,
- ioeGetHandle, ioeGetFileName
+ ioeGetErrorString,
+ ioeGetHandle, ioeGetFileName,
+ try, bracket, bracket_
) where
import Ix
import STBase
+import UnsafeST ( unsafePerformPrimIO, unsafeInterleavePrimIO )
import IOBase
import ArrBase ( MutableByteArray(..), newCharArray )
import IOHandle -- much of the real stuff is in here
-import PackedString ( nilPS, packCBytesST, unpackPS )
+import PackBase ( unpackNBytesST )
import PrelBase
import GHC
+import Foreign ( ForeignObj, Addr, makeForeignObj, writeForeignObj )
+import Char ( ord, chr )
\end{code}
%*********************************************************
hPrint :: Show a => Handle -> a -> IO ()
hPutChar :: Handle -> Char -> IO ()
hPutStr :: Handle -> String -> IO ()
+hPutStrLn :: Handle -> String -> IO ()
hReady :: Handle -> IO Bool
+hWaitForInput :: Handle -> Int -> IO Bool
+
--IOHandle:hSeek :: Handle -> SeekMode -> Integer -> IO ()
--IOHandle:hSetBuffering :: Handle -> BufferMode -> IO ()
--IOHandle:hSetPosn :: HandlePosn -> IO ()
-- ioeGetFileName :: IOError -> Maybe FilePath
+-- ioeGetErrorString :: IOError -> Maybe String
-- ioeGetHandle :: IOError -> Maybe Handle
-- isAlreadyExistsError :: IOError -> Bool
-- isAlreadyInUseError :: IOError -> Bool
--IOHandle:stdin, stdout, stderr :: Handle
\end{code}
+Standard instances for @Handle@:
+
+\begin{code}
+instance Eq IOError where
+ (IOError h1 e1 str1) == (IOError h2 e2 str2) =
+ e1==e2 && str1==str2 && h1==h2
+
+instance Eq Handle where
+ h1 == h2 =
+ unsafePerformPrimIO (
+ ioToPrimIO (readHandle h1) >>= \ h1_ ->
+ ioToPrimIO (writeHandle h1 h1_) >>
+ ioToPrimIO (readHandle h2) >>= \ h2_ ->
+ ioToPrimIO (writeHandle h2 h2_) >>
+ return (
+ case (h1_,h2_) of
+ (ErrorHandle (IOError h1 _ _), ErrorHandle (IOError h2 _ _)) -> h1 == h2
+ (ClosedHandle, ClosedHandle) -> True
+ (SemiClosedHandle v1 _, SemiClosedHandle v2 _) -> v1 == v2
+ (ReadHandle v1 _ _ , ReadHandle v2 _ _) -> v1 == v2
+ (WriteHandle v1 _ _ , WriteHandle v2 _ _) -> v1 == v2
+ (AppendHandle v1 _ _ , AppendHandle v2 _ _) -> v1 == v2
+ (ReadWriteHandle v1 _ _ , ReadWriteHandle v2 _ _) -> v1 == v2
+ _ -> False))
+
+instance Show Handle where {showsPrec p h = showString "<<Handle>>"}
+
+--Type declared in IOHandle, instance here because it depends on Eq.Handle
+instance Eq HandlePosn where
+ (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
+
+\end{code}
+
%*********************************************************
%* *
\subsection{Simple input operations}
%* *
%*********************************************************
-Computation $hReady hdl$ indicates whether at least
+Computation @hReady hdl@ indicates whether at least
one item is available for input from handle {\em hdl}.
+@hWaitForInput@ is the generalisation, wait for \tr{n} seconds
+before deciding whether the Handle has run dry or not.
+
\begin{code}
---hReady :: Handle -> IO Bool
-hReady handle =
+--hReady :: Handle -> IO Bool
+hReady h = hWaitForInput h 0
+
+--hWaitForInput :: Handle -> Int -> IO Bool
+hWaitForInput handle nsecs =
readHandle handle >>= \ htype ->
case htype of
ErrorHandle ioError ->
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
AppendHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not open for reading")
+ fail (IOError (Just handle) IllegalOperation "handle is not open for reading")
WriteHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not open for reading")
+ fail (IOError (Just handle) IllegalOperation "handle is not open for reading")
other ->
- _ccall_ inputReady (filePtr other) `thenIO_Prim` \ rc ->
- writeHandle handle (markHandle htype) >>
+ _ccall_ inputReady (filePtr other) nsecs `thenIO_Prim` \ rc ->
+ writeHandle handle (markHandle htype) >>
case rc of
0 -> return False
1 -> return True
- _ -> constructErrorAndFail "hReady"
+ _ -> constructErrorAndFail "hWaitForInput"
\end{code}
Computation $hGetChar hdl$ reads the next character from handle
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
AppendHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not open for reading")
+ fail (IOError (Just handle) IllegalOperation "handle is not open for reading")
WriteHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not open for reading")
+ fail (IOError (Just handle) IllegalOperation "handle is not open for reading")
other ->
_ccall_ fileGetc (filePtr other) `thenIO_Prim` \ intc ->
writeHandle handle (markHandle htype) >>
return (chr intc)
else
constructErrorAndFail "hGetChar"
+
+hGetLine :: Handle -> IO String
+hGetLine h =
+ hGetChar h >>= \ c ->
+ if c == '\n' then
+ return ""
+ else
+ hGetLine h >>= \ s -> return (c:s)
\end{code}
Computation $hLookahead hdl$ returns the next character from handle
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
AppendHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not open for reading")
+ fail (IOError (Just handle) IllegalOperation "handle is not open for reading")
WriteHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not open for reading")
+ fail (IOError (Just handle) IllegalOperation "handle is not open for reading")
other ->
_ccall_ fileLookAhead (filePtr other) `thenIO_Prim` \ intc ->
writeHandle handle (markHandle htype) >>
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
AppendHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not open for reading")
+ fail (IOError (Just handle) IllegalOperation "handle is not open for reading")
WriteHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not open for reading")
+ fail (IOError (Just handle) IllegalOperation "handle is not open for reading")
other ->
{-
To avoid introducing an extra layer of buffering here,
if buf /= ``NULL'' then
return (buf, size)
else
- fail (ResourceExhausted "not enough virtual memory")
+ fail (IOError Nothing ResourceExhausted "not enough virtual memory")
where
size =
case msize of
lazyReadChar :: Handle -> PrimIO String
lazyReadBlock handle =
- ioToST (readHandle handle) >>= \ htype ->
+ ioToST (readHandle handle) >>= \ htype ->
case htype of
-- There cannae be an ErrorHandle here
ClosedHandle ->
SemiClosedHandle fp (buf, size) ->
_ccall_ readBlock buf fp size >>= \ bytes ->
(if bytes <= 0
- then return nilPS
- else packCBytesST bytes buf) >>= \ some ->
+ then return ""
+ else unpackNBytesST buf bytes) >>= \ some ->
if bytes < 0 then
- ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0)))
- >>
_ccall_ free buf >>= \ () ->
_ccall_ closeFile fp >>
- returnPrimIO (unpackPS some)
+#ifndef __PARALLEL_HASKELL__
+ writeForeignObj fp ``NULL'' >>
+ ioToST (writeHandle handle (SemiClosedHandle fp (``NULL'', 0))) >>
+#else
+ ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))) >>
+#endif
+ returnPrimIO some
else
ioToST (writeHandle handle htype) >>
unsafeInterleavePrimIO (lazyReadBlock handle)
>>= \ more ->
- returnPrimIO (unpackPS some ++ more)
+ returnPrimIO (some ++ more)
lazyReadLine handle =
- ioToST (readHandle handle) >>= \ htype ->
+ ioToST (readHandle handle) >>= \ htype ->
case htype of
-- There cannae be an ErrorHandle here
ClosedHandle ->
SemiClosedHandle fp (buf, size) ->
_ccall_ readLine buf fp size >>= \ bytes ->
(if bytes <= 0
- then return nilPS
- else packCBytesST bytes buf) >>= \ some ->
+ then return ""
+ else unpackNBytesST buf bytes) >>= \ some ->
if bytes < 0 then
- ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0)))
- >>
_ccall_ free buf >>= \ () ->
_ccall_ closeFile fp >>
- returnPrimIO (unpackPS some)
+#ifndef __PARALLEL_HASKELL__
+ writeForeignObj fp ``NULL'' >>
+ ioToST (writeHandle handle (SemiClosedHandle fp (``NULL'', 0))) >>
+#else
+ ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))) >>
+#endif
+ return some
else
ioToST (writeHandle handle htype) >>
unsafeInterleavePrimIO (lazyReadLine handle)
>>= \ more ->
- returnPrimIO (unpackPS some ++ more)
+ return (some ++ more)
lazyReadChar handle =
- ioToST (readHandle handle) >>= \ htype ->
+ ioToST (readHandle handle) >>= \ htype ->
case htype of
-- There cannae be an ErrorHandle here
ClosedHandle ->
SemiClosedHandle fp buf_info ->
_ccall_ readChar fp >>= \ char ->
if char == ``EOF'' then
- ioToST (writeHandle handle (SemiClosedHandle ``NULL'' buf_info))
- >>
_ccall_ closeFile fp >>
+#ifndef __PARALLEL_HASKELL__
+ writeForeignObj fp ``NULL'' >>
+ ioToST (writeHandle handle (SemiClosedHandle fp (``NULL'', 0))) >>
+#else
+ ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))) >>
+#endif
returnPrimIO ""
else
ioToST (writeHandle handle htype) >>
unsafeInterleavePrimIO (lazyReadChar handle)
>>= \ more ->
returnPrimIO (chr char : more)
+
\end{code}
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
ReadHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not open for writing")
+ fail (IOError (Just handle) IllegalOperation "handle is not open for writing")
other ->
_ccall_ filePutc (filePtr other) (ord c) `thenIO_Prim` \ rc ->
writeHandle handle (markHandle htype) >>
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
ReadHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not open for writing")
+ fail (IOError (Just handle) IllegalOperation "handle is not open for writing")
other ->
+ {-
+ The code below is not correct for line-buffered terminal streams,
+ as the output stream is not flushed when terminal input is requested
+ again, just upon seeing a newline character. A temporary fix for the
+ most common line-buffered output stream, stdout, is to assume the
+ buffering it was given when created (no buffering). This is not
+ as bad as it looks, since stdio buffering sits underneath this.
+
+ ToDo: fix me
+ -}
getBufferMode other `thenIO_Prim` \ other ->
(case bufferMode other of
Just LineBuffering ->
- writeLines (filePtr other) str
+ writeChars (filePtr other) str
+ --writeLines (filePtr other) str
Just (BlockBuffering (Just size)) ->
writeBlocks (filePtr other) size str
Just (BlockBuffering Nothing) ->
else
constructErrorAndFail "hPutStr"
where
+#ifndef __PARALLEL_HASKELL__
+ writeLines :: ForeignObj -> String -> PrimIO Bool
+#else
writeLines :: Addr -> String -> PrimIO Bool
+#endif
writeLines = writeChunks ``BUFSIZ'' True
+#ifndef __PARALLEL_HASKELL__
+ writeBlocks :: ForeignObj -> Int -> String -> PrimIO Bool
+#else
writeBlocks :: Addr -> Int -> String -> PrimIO Bool
+#endif
writeBlocks fp size s = writeChunks size False fp s
{-
a whole lot quicker. -- SOF 3/96
-}
+#ifndef __PARALLEL_HASKELL__
+ writeChunks :: Int -> Bool -> ForeignObj -> String -> PrimIO Bool
+#else
writeChunks :: Int -> Bool -> Addr -> String -> PrimIO Bool
-
+#endif
writeChunks (I# bufLen) chopOnNewLine fp s =
newCharArray (0,I# bufLen) >>= \ arr@(MutableByteArray _ arr#) ->
let
((C# x):xs) ->
write_char arr# n x >>
- {- Flushing lines - should we bother? -}
- if n ==# bufLen {- || (chopOnNewLine && (x `eqChar#` '\n'#)) -} then
+ {- Flushing lines - should we bother? Yes, for line-buffered output. -}
+ if n ==# bufLen || (chopOnNewLine && (x `eqChar#` '\n'#)) then
_ccall_ writeFile arr fp (I# (n +# 1#)) >>= \ rc ->
if rc == 0 then
shoveString 0# xs
in
shoveString 0# s
+#ifndef __PARALLEL_HASKELL__
+ writeChars :: ForeignObj -> String -> PrimIO Bool
+#else
writeChars :: Addr -> String -> PrimIO Bool
+#endif
writeChars fp "" = returnPrimIO True
writeChars fp (c:cs) =
_ccall_ filePutc fp (ord c) >>= \ rc ->
given by the $shows$ function to the file or channel managed by {\em
hdl}.
+SOF 2/97: Seem to have disappeared in 1.4 libs.
+
\begin{code}
--hPrint :: Show a => Handle -> a -> IO ()
hPrint hdl = hPutStr hdl . show
\end{code}
+
+Derived action @hPutStrLn hdl str@ writes the string \tr{str} to
+the handle \tr{hdl}, adding a newline at the end.
+
+\begin{code}
+--hPutStrLn :: Handle -> String -> IO ()
+hPutStrLn hndl str = do
+ hPutStr hndl str
+ hPutChar hndl '\n'
+
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Try and bracket}
+%* *
+%*********************************************************
+
+The construct $try comp$ exposes errors which occur within a
+computation, and which are not fully handled. It always succeeds.
+
+\begin{code}
+try :: IO a -> IO (Either IOError a)
+try f = catch (do r <- f
+ return (Right r))
+ (return . Left)
+
+bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
+bracket before after m = do
+ x <- before
+ rs <- try (m x)
+ after x
+ case rs of
+ Right r -> return r
+ Left e -> fail e
+
+-- variant of the above where middle computation doesn't want x
+bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c
+bracket_ before after m = do
+ x <- before
+ rs <- try m
+ after x
+ case rs of
+ Right r -> return r
+ Left e -> fail e
+\end{code}
+
projects / ghc-hetmet.git / blobdiff