hFileSize, hIsEOF, isEOF,
hSetBuffering, hGetBuffering, hFlush,
hGetPosn, hSetPosn, hSeek,
- hReady, hGetChar, hLookAhead, hGetContents,
+ hWaitForInput, hReady, hGetChar, hGetLine, hLookAhead, hGetContents,
hPutChar, hPutStr, hPutStrLn, hPrint,
hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable,
isFullError, isEOFError,
isIllegalOperation, isPermissionError, isUserError,
ioeGetErrorString,
- ioeGetHandle, ioeGetFileName
+ 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 ( makeForeignObj )
+import Foreign ( ForeignObj, Addr, makeForeignObj, writeForeignObj )
+import Char ( ord, chr )
\end{code}
%*********************************************************
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 ()
--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 ->
writeHandle handle htype >>
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
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
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
- makeForeignObj ``NULL'' ``&freeFile'' >>= \ null_fp ->
- ioToST (writeHandle handle (SemiClosedHandle null_fp (``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
- makeForeignObj ``NULL'' ``&freeFile'' >>= \ null_fp ->
- ioToST (writeHandle handle (SemiClosedHandle null_fp (``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
- makeForeignObj ``NULL'' ``&freeFile'' >>= \ null_fp ->
- ioToST (writeHandle handle (SemiClosedHandle null_fp 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}
writeHandle handle htype >>
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 ->
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}
+