X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FIO.lhs;h=7e207f1cb68c5c6b0c1e8d1cc7023c8cb2ad1456;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=fe5851888e8f776f9cb6ebd6fd8339b3787d6af6;hpb=28139aea50376444d56f43f0914291348a51a7e7;p=ghc-hetmet.git diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index fe58518..7e207f1 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -1,145 +1,157 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1998 % - \section[IO]{Module @IO@} +Implementation of the standard Haskell IO interface, see +@http://haskell.org/onlinelibrary/io.html@ for the official +definition. + \begin{code} {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} +#ifndef BODY /* Hugs just includes this in PreludeBuiltin so no header needed */ module IO ( - Handle, HandlePosn, + Handle, -- abstract, instance of: Eq, Show. + HandlePosn(..), -- abstract, instance of: Eq, Show. IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode), BufferMode(NoBuffering,LineBuffering,BlockBuffering), SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd), - stdin, stdout, stderr, - - 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, - ioeGetErrorString, - ioeGetHandle, ioeGetFileName, - try, bracket, bracket_ + stdin, stdout, stderr, -- :: Handle + + openFile, -- :: FilePath -> IOMode -> IO Handle + hClose, -- :: Handle -> IO () + hFileSize, -- :: Handle -> IO Integer + hIsEOF, -- :: Handle -> IO Bool + isEOF, -- :: IO Bool + + hSetBuffering, -- :: Handle -> BufferMode -> IO () + hGetBuffering, -- :: Handle -> IO BufferMode + hFlush, -- :: Handle -> IO () + hGetPosn, -- :: Handle -> IO HandlePosn + hSetPosn, -- :: Handle -> HandlePosn -> IO () + hSeek, -- :: Handle -> SeekMode -> Integer -> IO () + hWaitForInput, -- :: Handle -> Int -> IO Bool + hReady, -- :: Handle -> IO Bool + hGetChar, -- :: Handle -> IO Char + hGetLine, -- :: Handle -> IO [Char] + hLookAhead, -- :: Handle -> IO Char + hGetContents, -- :: Handle -> IO [Char] + hPutChar, -- :: Handle -> Char -> IO () + hPutStr, -- :: Handle -> [Char] -> IO () + hPutStrLn, -- :: Handle -> [Char] -> IO () + hPrint, -- :: Show a => Handle -> a -> IO () + hIsOpen, hIsClosed, -- :: Handle -> IO Bool + hIsReadable, hIsWritable, -- :: Handle -> IO Bool + hIsSeekable, -- :: Handle -> IO Bool + + isAlreadyExistsError, isDoesNotExistError, -- :: IOError -> Bool + isAlreadyInUseError, isFullError, + isEOFError, isIllegalOperation, + isPermissionError, isUserError, + + ioeGetErrorString, -- :: IOError -> String + ioeGetHandle, -- :: IOError -> Maybe Handle + ioeGetFileName, -- :: IOError -> Maybe FilePath + + try, -- :: IO a -> IO (Either IOError a) + bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c + bracket_, -- :: IO a -> (a -> IO b) -> IO c -> IO c + + -- Non-standard extension (but will hopefully become standard with 1.5) is + -- to export the Prelude io functions via IO (in addition to exporting them + -- from the prelude...for now.) + putChar, -- :: Char -> IO () + putStr, -- :: String -> IO () + putStrLn, -- :: String -> IO () + print, -- :: Show a => a -> IO () + getChar, -- :: IO Char + getLine, -- :: IO String + getContents, -- :: IO String + interact, -- :: (String -> String) -> IO () + readFile, -- :: FilePath -> IO String + writeFile, -- :: FilePath -> String -> IO () + appendFile, -- :: FilePath -> String -> IO () + readIO, -- :: Read a => String -> IO a + readLn, -- :: Read a => IO a + FilePath, -- :: String + fail, -- :: IOError -> IO a + catch, -- :: IO a -> (IOError -> IO a) -> IO a + userError, -- :: String -> IOError + + IO, -- non-standard, amazingly enough. + IOError, -- ditto + + -- extensions + hPutBuf, +#ifndef __HUGS__ + hPutBufBA, +#endif + slurpFile + ) where -import PrelST -import PrelUnsafe ( unsafePerformIO, unsafeInterleaveIO ) +#ifdef __HUGS__ + +import PreludeBuiltin + +#else + +--import PrelST +import PrelBase + import PrelIOBase -import PrelArr ( MutableByteArray(..), newCharArray ) import PrelHandle -- much of the real stuff is in here -import PrelPack ( unpackNBytesST ) -import PrelBase -import PrelRead ( readParen, Read(..), reads, lex ) -import PrelMaybe -import PrelEither -import PrelAddr -import PrelGHC + +import PrelRead ( readParen, Read(..), reads, lex, + readIO + ) +--import PrelNum ( toInteger ) +import PrelBounded () -- Bounded Int instance. +import PrelEither ( Either(..) ) +import PrelAddr ( Addr(..), nullAddr ) +import PrelArr ( ByteArray ) +import PrelPack ( unpackNBytesAccST ) +import PrelException ( fail, catch ) #ifndef __PARALLEL_HASKELL__ -import PrelForeign ( ForeignObj, makeForeignObj, writeForeignObj ) +import PrelForeign ( ForeignObj ) #endif -import Ix import Char ( ord, chr ) -\end{code} -%********************************************************* -%* * -\subsection{Signatures} -%* * -%********************************************************* +#endif /* ndef __HUGS__ */ +#endif /* ndef BODY */ + +#ifndef HEAD + +#ifdef __HUGS__ +#define cat2(x,y) x/**/y +#define CCALL(fun) cat2(prim_,fun) +#define __CONCURRENT_HASKELL__ +#define stToIO id +#define unpackNBytesAccST primUnpackCStringAcc +#else +#define CCALL(fun) _ccall_ fun +#define ref_freeStdFileObject (``&freeStdFileObject''::Addr) +#define ref_freeFileObject (``&freeFileObject''::Addr) +#define const_BUFSIZ ``BUFSIZ'' +#endif -\begin{code} ---IOHandle:hClose :: Handle -> IO () ---IOHandle:hFileSize :: Handle -> IO Integer ---IOHandle:hFlush :: Handle -> IO () ---IOHandle:hGetBuffering :: Handle -> IO BufferMode -hGetChar :: Handle -> IO Char -hGetContents :: Handle -> IO String ---IOHandle:hGetPosn :: Handle -> IO HandlePosn ---IOHandle:hIsClosed :: Handle -> IO Bool ---IOHandle:hIsEOF :: Handle -> IO Bool ---IOHandle:hIsOpen :: Handle -> IO Bool ---IOHandle:hIsReadable :: Handle -> IO Bool ---IOHandle:hIsSeekable :: Handle -> IO Bool ---IOHandle:hIsWritable :: Handle -> IO Bool -hLookAhead :: Handle -> IO Char -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:isEOF :: IO Bool --- isEOFError :: IOError -> Bool --- isFullError :: IOError -> Bool --- isIllegalOperation :: IOError -> Bool --- isPermissionError :: IOError -> Bool --- isUserError :: IOError -> Bool ---IOHandle:openFile :: FilePath -> IOMode -> IO Handle ---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 - -#ifndef __CONCURRENT_HASKELL__ + (IOError h1 e1 loc1 str1) == (IOError h2 e2 loc2 str2) = + e1==e2 && str1==str2 && h1==h2 && loc1 == loc2 instance Eq Handle where (Handle h1) == (Handle h2) = h1 == h2 -#else - -{- OLD equality instance. The simpler one above - seems more accurate! This one is still used for concurrent haskell, - since there's no equality instance over MVars. --} - -instance Eq Handle where - h1 == h2 = - unsafePerformIO (do - h1_ <- readHandle h1 - writeHandle h1 h1_ - h2_<- readHandle h2 - 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)) - -#endif - -instance Show Handle where {showsPrec p h = showString "<>"} - --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 @@ -167,116 +179,69 @@ instance Read BufferMode where 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 +@hWaitForInput@ is the generalisation, wait for \tr{n} milliseconds before deciding whether the Handle has run dry or not. +If @hWaitForInput@ finds anything in the Handle's buffer, it immediately returns. +If not, it tries to read from the underlying OS handle. Notice that +for buffered Handles connected to terminals this means waiting until a complete +line is available. + \begin{code} ---hReady :: Handle -> IO Bool +hReady :: Handle -> IO Bool hReady h = hWaitForInput h 0 ---hWaitForInput :: Handle -> Int -> IO Bool -hWaitForInput handle nsecs = do - htype <- readHandle handle - case htype of - ErrorHandle ioError -> do - writeHandle handle htype - fail ioError - ClosedHandle -> do - writeHandle handle htype - ioe_closedHandle handle - SemiClosedHandle _ _ -> do - writeHandle handle htype - ioe_closedHandle handle - AppendHandle _ _ _ -> do - writeHandle handle htype - fail (IOError (Just handle) IllegalOperation - "handle is not open for reading") - WriteHandle _ _ _ -> do - writeHandle handle htype - fail (IOError (Just handle) IllegalOperation - "handle is not open for reading") - other -> do - rc <- _ccall_ inputReady (filePtr other) nsecs - writeHandle handle (markHandle htype) - case rc of - 0 -> return False - 1 -> return True - _ -> constructErrorAndFail "hWaitForInput" +hWaitForInput :: Handle -> Int -> IO Bool +hWaitForInput handle msecs = + wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do + rc <- CCALL(inputReady) (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block + writeHandle handle handle_ + case rc of + 0 -> return False + 1 -> return True + _ -> constructErrorAndFail "hWaitForInput" \end{code} -Computation $hGetChar hdl$ reads the next character from handle -{\em hdl}, blocking until a character is available. +@hGetChar hdl@ reads the next character from handle @hdl@, +blocking until a character is available. \begin{code} ---hGetChar :: Handle -> IO Char - -hGetChar handle = do - htype <- readHandle handle - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - ioe_closedHandle handle - SemiClosedHandle _ _ -> - writeHandle handle htype >> - ioe_closedHandle handle - AppendHandle _ _ _ -> - writeHandle handle htype >> - fail (IOError (Just handle) IllegalOperation "handle is not open for reading") - WriteHandle _ _ _ -> - writeHandle handle htype >> - fail (IOError (Just handle) IllegalOperation "handle is not open for reading") - other -> do - intc <- _ccall_ fileGetc (filePtr other) - writeHandle handle (markHandle htype) - if intc /= ``EOF'' then - return (chr intc) - else - constructErrorAndFail "hGetChar" +hGetChar :: Handle -> IO Char +hGetChar handle = + wantReadableHandle "hGetChar" handle $ \ handle_ -> do + let fo = haFO__ handle_ + intc <- mayBlock fo (CCALL(fileGetc) fo) -- ConcHask: UNSAFE, may block + writeHandle handle handle_ + if intc /= (-1) + then 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) +hGetLine h = do + c <- hGetChar h + if c == '\n' + then return "" + else do + s <- hGetLine h + return (c:s) + \end{code} -Computation $hLookahead hdl$ returns the next character from handle -{\em hdl} without removing it from the input buffer, blocking until a +@hLookahead hdl@ returns the next character from handle @hdl@ +without removing it from the input buffer, blocking until a character is available. \begin{code} ---hLookAhead :: Handle -> IO Char - -hLookAhead handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - ioe_closedHandle handle - SemiClosedHandle _ _ -> - writeHandle handle htype >> - ioe_closedHandle handle - AppendHandle _ _ _ -> - writeHandle handle htype >> - fail (IOError (Just handle) IllegalOperation "handle is not open for reading") - WriteHandle _ _ _ -> - writeHandle handle htype >> - fail (IOError (Just handle) IllegalOperation "handle is not open for reading") - other -> do - intc <- _ccall_ fileLookAhead (filePtr other) - writeHandle handle (markHandle htype) - if intc /= ``EOF'' then - return (chr intc) - else - constructErrorAndFail "hLookAhead" +hLookAhead :: Handle -> IO Char +hLookAhead handle = do + wantReadableHandle "hLookAhead" handle $ \ handle_ -> do + let fo = haFO__ handle_ + intc <- mayBlock fo (CCALL(fileLookAhead) fo) -- ConcHask: UNSAFE, may block + writeHandle handle handle_ + if intc /= (-1) + then return (chr intc) + else constructErrorAndFail "hLookAhead" + \end{code} @@ -286,160 +251,94 @@ hLookAhead handle = %* * %********************************************************* -Computation $hGetContents hdl$ returns the list of characters -corresponding to the unread portion of the channel or file managed by -{\em hdl}, which is made semi-closed. +@hGetContents hdl@ returns the list of characters corresponding +to the unread portion of the channel or file managed by @hdl@, +which is made semi-closed. \begin{code} ---hGetContents :: Handle -> IO String - -hGetContents handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - ioe_closedHandle handle - SemiClosedHandle _ _ -> - writeHandle handle htype >> - ioe_closedHandle handle - AppendHandle _ _ _ -> - writeHandle handle htype >> - fail (IOError (Just handle) IllegalOperation "handle is not open for reading") - WriteHandle _ _ _ -> - writeHandle handle htype >> - fail (IOError (Just handle) IllegalOperation "handle is not open for reading") - other -> - {- - To avoid introducing an extra layer of buffering here, - we provide three lazy read methods, based on character, - line, and block buffering. - -} - getBufferMode other >>= \ other -> - case (bufferMode other) of - Just LineBuffering -> - allocBuf Nothing >>= \ buf_info -> - writeHandle handle (SemiClosedHandle (filePtr other) buf_info) - >> - unsafeInterleaveIO (lazyReadLine handle) - >>= \ contents -> - return contents - - Just (BlockBuffering size) -> - allocBuf size >>= \ buf_info -> - writeHandle handle (SemiClosedHandle (filePtr other) buf_info) - >> - unsafeInterleaveIO (lazyReadBlock handle) - >>= \ contents -> - return contents - _ -> -- Nothing is treated pessimistically as NoBuffering - writeHandle handle (SemiClosedHandle (filePtr other) (``NULL'', 0)) - >> - unsafeInterleaveIO (lazyReadChar handle) >>= \ contents -> - return contents - where - allocBuf :: Maybe Int -> IO (Addr, Int) - allocBuf msize = - _ccall_ malloc size >>= \ buf -> - if buf /= ``NULL'' then - return (buf, size) - else - fail (IOError Nothing ResourceExhausted "not enough virtual memory") - where - size = - case msize of - Just x -> x - Nothing -> ``BUFSIZ'' +hGetContents :: Handle -> IO String +hGetContents handle = + wantReadableHandle "hGetContents" handle $ \ handle_ -> do + {- + To avoid introducing an extra layer of buffering here, + we provide three lazy read methods, based on character, + line, and block buffering. + -} + writeHandle handle (handle_{ haType__ = SemiClosedHandle }) + case (haBufferMode__ handle_) of + LineBuffering -> unsafeInterleaveIO (lazyReadLine handle (haFO__ handle_)) + BlockBuffering _ -> unsafeInterleaveIO (lazyReadBlock handle (haFO__ handle_)) + NoBuffering -> unsafeInterleaveIO (lazyReadChar handle (haFO__ handle_)) + \end{code} -Note that someone may yank our handle out from under us, and then re-use -the same FILE * for something else. Therefore, we have to re-examine the -handle every time through. +Note that someone may close the semi-closed handle (or change its buffering), +so each these lazy read functions are pulled on, they have to check whether +the handle has indeed been closed. \begin{code} -lazyReadBlock :: Handle -> IO String -lazyReadLine :: Handle -> IO String -lazyReadChar :: Handle -> IO String - -lazyReadBlock handle = - readHandle handle >>= \ htype -> - case htype of - -- There cannae be an ErrorHandle here - ClosedHandle -> - writeHandle handle htype >> - return "" - SemiClosedHandle fp (buf, size) -> - _ccall_ readBlock buf fp size >>= \ bytes -> - (if bytes <= 0 - then return "" - else stToIO (unpackNBytesST buf bytes)) >>= \ some -> - if bytes < 0 then - _ccall_ free buf >>= \ () -> - _ccall_ closeFile fp >> #ifndef __PARALLEL_HASKELL__ - writeForeignObj fp ``NULL'' >> - writeHandle handle (SemiClosedHandle fp (``NULL'', 0)) >> +lazyReadBlock :: Handle -> ForeignObj -> IO String +lazyReadLine :: Handle -> ForeignObj -> IO String +lazyReadChar :: Handle -> ForeignObj -> IO String #else - writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0)) >> +lazyReadBlock :: Handle -> Addr -> IO String +lazyReadLine :: Handle -> Addr -> IO String +lazyReadChar :: Handle -> Addr -> IO String #endif - return some - else - writeHandle handle htype >> - unsafeInterleaveIO (lazyReadBlock handle) >>= \ more -> - return (some ++ more) - -lazyReadLine handle = - readHandle handle >>= \ htype -> - case htype of - -- There cannae be an ErrorHandle here - ClosedHandle -> - writeHandle handle htype >> - return "" - SemiClosedHandle fp (buf, size) -> - _ccall_ readLine buf fp size >>= \ bytes -> - (if bytes <= 0 - then return "" - else stToIO (unpackNBytesST buf bytes)) >>= \ some -> - if bytes < 0 then - _ccall_ free buf >>= \ () -> - _ccall_ closeFile fp >> -#ifndef __PARALLEL_HASKELL__ - writeForeignObj fp ``NULL'' >> - writeHandle handle (SemiClosedHandle fp (``NULL'', 0)) >> -#else - writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0)) >> -#endif - return some - else - writeHandle handle htype >> - unsafeInterleaveIO (lazyReadLine handle) - >>= \ more -> - return (some ++ more) - -lazyReadChar handle = - readHandle handle >>= \ htype -> - case htype of - -- There cannae be an ErrorHandle here - ClosedHandle -> - writeHandle handle htype >> + +lazyReadBlock handle fo = do + buf <- CCALL(getBufStart) fo (0::Int) + bytes <- mayBlock fo (CCALL(readBlock) fo) -- ConcHask: UNSAFE, may block. + case bytes of + -3 -> -- buffering has been turned off, use lazyReadChar instead + lazyReadChar handle fo + -2 -> return "" + -1 -> -- an error occurred, close the handle + withHandle handle $ \ handle_ -> do + CCALL(closeFile) (haFO__ handle_) 0{-don't bother flushing-} -- ConcHask: SAFE, won't block. + writeHandle handle (handle_ { haType__ = ClosedHandle, + haFO__ = nullFile__ }) return "" - SemiClosedHandle fp buf_info -> - _ccall_ readChar fp >>= \ char -> - if char == ``EOF'' then - _ccall_ closeFile fp >> -#ifndef __PARALLEL_HASKELL__ - writeForeignObj fp ``NULL'' >> - writeHandle handle (SemiClosedHandle fp (``NULL'', 0)) >> -#else - writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0)) >> -#endif - return "" - else - writeHandle handle htype >> - unsafeInterleaveIO (lazyReadChar handle) >>= \ more -> - return (chr char : more) + _ -> do + more <- unsafeInterleaveIO (lazyReadBlock handle fo) + stToIO (unpackNBytesAccST buf bytes more) + +lazyReadLine handle fo = do + bytes <- mayBlock fo (CCALL(readLine) fo) -- ConcHask: UNSAFE, may block. + case bytes of + -3 -> -- buffering has been turned off, use lazyReadChar instead + lazyReadChar handle fo + -2 -> return "" -- handle closed by someone else, stop reading. + -1 -> -- an error occurred, close the handle + withHandle handle $ \ handle_ -> do + CCALL(closeFile) (haFO__ handle_) 0{- don't bother flushing-} -- ConcHask: SAFE, won't block + writeHandle handle (handle_ { haType__ = ClosedHandle, + haFO__ = nullFile__ }) + return "" + _ -> do + more <- unsafeInterleaveIO (lazyReadLine handle fo) + buf <- CCALL(getBufStart) fo bytes -- ConcHask: won't block + stToIO (unpackNBytesAccST buf bytes more) + +lazyReadChar handle fo = do + char <- mayBlock fo (CCALL(readChar) fo) -- ConcHask: UNSAFE, may block. + case char of + -4 -> -- buffering is now block-buffered, use lazyReadBlock instead + lazyReadBlock handle fo + + -3 -> -- buffering is now line-buffered, use lazyReadLine instead + lazyReadLine handle fo + -2 -> return "" + -1 -> -- error, silently close handle. + withHandle handle $ \ handle_ -> do + CCALL(closeFile) (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block + writeHandle handle (handle_{ haType__ = ClosedHandle, + haFO__ = nullFile__ }) + return "" + _ -> do + more <- unsafeInterleaveIO (lazyReadChar handle fo) + return (chr char : more) \end{code} @@ -450,181 +349,277 @@ lazyReadChar handle = %* * %********************************************************* -Computation $hPutChar hdl c$ writes the character {\em c} to the file -or channel managed by {\em hdl}. Characters may be buffered if -buffering is enabled for {\em hdl}. +@hPutChar hdl ch@ writes the character @ch@ to the file +or channel managed by @hdl@. Characters may be buffered if +buffering is enabled for @hdl@ \begin{code} ---hPutChar :: Handle -> Char -> IO () - -hPutChar handle c = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - ioe_closedHandle handle - SemiClosedHandle _ _ -> - writeHandle handle htype >> - ioe_closedHandle handle - ReadHandle _ _ _ -> - writeHandle handle htype >> - fail (IOError (Just handle) IllegalOperation "handle is not open for writing") - other -> - _ccall_ filePutc (filePtr other) (ord c) >>= \ rc -> - writeHandle handle (markHandle htype) >> - if rc == 0 then - return () - else - constructErrorAndFail "hPutChar" +hPutChar :: Handle -> Char -> IO () +hPutChar handle c = + wantWriteableHandle "hPutChar" handle $ \ handle_ -> do + let fo = haFO__ handle_ + rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block. + writeHandle handle handle_ + if rc == 0 + then return () + else constructErrorAndFail "hPutChar" + \end{code} -Computation $hPutStr hdl s$ writes the string {\em s} to the file or -channel managed by {\em hdl}. +@hPutStr hdl s@ writes the string @s@ to the file or +channel managed by @hdl@, buffering the output if needs be. \begin{code} ---hPutStr :: Handle -> String -> IO () - +hPutStr :: Handle -> String -> IO () hPutStr handle str = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - ioe_closedHandle handle - SemiClosedHandle _ _ -> - writeHandle handle htype >> - ioe_closedHandle handle - ReadHandle _ _ _ -> - 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 + wantWriteableHandle "hPutStr" handle $ \ handle_ -> do + let fo = haFO__ handle_ + case haBufferMode__ handle_ of + LineBuffering -> do + buf <- CCALL(getWriteableBuf) fo + pos <- CCALL(getBufWPtr) fo + bsz <- CCALL(getBufSize) fo + writeLines fo buf bsz pos str + BlockBuffering _ -> do + buf <- CCALL(getWriteableBuf) fo + pos <- CCALL(getBufWPtr) fo + bsz <- CCALL(getBufSize) fo + writeBlocks fo buf bsz pos str + NoBuffering -> do + writeChars fo str + writeHandle handle handle_ + +\end{code} + +Going across the border between Haskell and C is relatively costly, +so for block writes we pack the character strings on the Haskell-side +before passing the external write routine a pointer to the buffer. + +\begin{code} +#ifdef __HUGS__ + +#ifdef __CONCURRENT_HASKELL__ +/* See comment in shoveString below for explanation */ +#warning delayed update of buffer disnae work with killThread +#endif + +#ifndef __PARALLEL_HASKELL__ +writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO () +#else +writeLines :: Addr -> Addr -> Int -> Int -> String -> IO () +#endif +writeLines obj buf bufLen initPos s = + let + shoveString :: Int -> [Char] -> IO () + shoveString n ls = + case ls of + [] -> + if n == 0 then + CCALL(setBufWPtr) obj (0::Int) + else do + {- + At the end of a buffer write, update the buffer position + in the underlying file object, so that if the handle + is subsequently dropped by the program, the whole + buffer will be properly flushed. + + There's one case where this delayed up-date of the buffer + position can go wrong: if a thread is killed, it might be + in the middle of filling up a buffer, with the result that + the partial buffer update is lost upon finalisation. Not + that killing of threads is supported at the moment. + -} - getBufferMode other >>= \ other -> - (case bufferMode other of - Just LineBuffering -> - writeChars (filePtr other) str - --writeLines (filePtr other) str - Just (BlockBuffering (Just size)) -> - writeBlocks (filePtr other) size str - Just (BlockBuffering Nothing) -> - writeBlocks (filePtr other) ``BUFSIZ'' str - _ -> -- Nothing is treated pessimistically as NoBuffering - writeChars (filePtr other) str - ) >>= \ success -> - writeHandle handle (markHandle other) >> - if success then - return () - else - constructErrorAndFail "hPutStr" - where + CCALL(setBufWPtr) obj n + + (x:xs) -> do + primWriteCharOffAddr buf n x + {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -} + if n == bufLen || x == '\n' + then do + rc <- mayBlock obj (CCALL(writeFileObject) obj (n + 1)) -- ConcHask: UNSAFE, may block. + if rc == 0 + then shoveString 0 xs + else constructErrorAndFail "writeLines" + else + shoveString (n + 1) xs + in + shoveString initPos s +#else /* ndef __HUGS__ */ #ifndef __PARALLEL_HASKELL__ - writeLines :: ForeignObj -> String -> IO Bool +writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO () #else - writeLines :: Addr -> String -> IO Bool +writeLines :: Addr -> Addr -> Int -> Int -> String -> IO () #endif - writeLines = writeChunks ``BUFSIZ'' True +writeLines obj buf bf@(I# bufLen) (I# initPos#) s = + let + write_char :: Addr -> Int# -> Char# -> IO () + write_char (A# buf) n# c# = + IO $ \ s# -> + case (writeCharOffAddr# buf n# c# s#) of s2# -> (# s2#, () #) + + shoveString :: Int# -> [Char] -> IO () + shoveString n ls = + case ls of + [] -> + if n ==# 0# then + CCALL(setBufWPtr) obj (0::Int) + else do + {- + At the end of a buffer write, update the buffer position + in the underlying file object, so that if the handle + is subsequently dropped by the program, the whole + buffer will be properly flushed. + + There's one case where this delayed up-date of the buffer + position can go wrong: if a thread is killed, it might be + in the middle of filling up a buffer, with the result that + the partial buffer update is lost upon finalisation. Not + that killing of threads is supported at the moment. + -} + CCALL(setBufWPtr) obj (I# n) + + ((C# x):xs) -> do + write_char buf n x + {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -} + if n ==# bufLen || x `eqChar#` '\n'# + then do + rc <- mayBlock obj (CCALL(writeFileObject) obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block. + if rc == 0 + then shoveString 0# xs + else constructErrorAndFail "writeLines" + else + shoveString (n +# 1#) xs + in + shoveString initPos# s +#endif /* ndef __HUGS__ */ + +#ifdef __HUGS__ #ifndef __PARALLEL_HASKELL__ - writeBlocks :: ForeignObj -> Int -> String -> IO Bool +writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO () #else - writeBlocks :: Addr -> Int -> String -> IO Bool +writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO () #endif - writeBlocks fp size s = writeChunks size False fp s - - {- - The breaking up of output into lines along \n boundaries - works fine as long as there are newlines to split by. - Avoid the splitting up into lines alltogether (doesn't work - for overly long lines like the stuff that showsPrec instances - normally return). Instead, we split them up into fixed size - chunks before blasting them off to the Real World. - - Hacked to avoid multiple passes over the strings - unsightly, but - a whole lot quicker. -- SOF 3/96 - -} +writeBlocks obj buf bufLen initPos s = + let + shoveString :: Int -> [Char] -> IO () + shoveString n ls = + case ls of + [] -> + if n == 0 then + CCALL(setBufWPtr) obj (0::Int) + else do + {- + At the end of a buffer write, update the buffer position + in the underlying file object, so that if the handle + is subsequently dropped by the program, the whole + buffer will be properly flushed. + + There's one case where this delayed up-date of the buffer + position can go wrong: if a thread is killed, it might be + in the middle of filling up a buffer, with the result that + the partial buffer update is lost upon finalisation. However, + by the time killThread is supported, Haskell finalisers are also + likely to be in, which means the 'IOFileObject' hack can go + alltogether. + -} + CCALL(setBufWPtr) obj n + + (x:xs) -> do + primWriteCharOffAddr buf n x + if n == bufLen + then do + rc <- mayBlock obj (CCALL(writeFileObject) obj (n + 1)) -- ConcHask: UNSAFE, may block. + if rc == 0 + then shoveString 0 xs + else constructErrorAndFail "writeChunks" + else + shoveString (n + 1) xs + in + shoveString initPos s +#else /* ndef __HUGS__ */ #ifndef __PARALLEL_HASKELL__ - writeChunks :: Int -> Bool -> ForeignObj -> String -> IO Bool +writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO () #else - writeChunks :: Int -> Bool -> Addr -> String -> IO Bool +writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO () #endif - writeChunks (I# bufLen) chopOnNewLine fp s = - stToIO (newCharArray (0,I# bufLen)) >>= \ arr@(MutableByteArray _ arr#) -> - let - write_char :: MutableByteArray# RealWorld -> Int# -> Char# -> IO () - write_char arr# n x = IO $ \ s# -> - case (writeCharArray# arr# n x s#) of { s1# -> - IOok s1# () } - - shoveString :: Int# -> [Char] -> IO Bool - shoveString n ls = - case ls of - [] -> - if n ==# 0# then - return True - else - _ccall_ writeFile arr fp (I# n) >>= \rc -> - return (rc==0) - - ((C# x):xs) -> - write_char arr# n x >> - - {- 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 - else - return False - else - shoveString (n +# 1#) xs - in - shoveString 0# s +writeBlocks obj buf bf@(I# bufLen) (I# initPos#) s = + let + write_char :: Addr -> Int# -> Char# -> IO () + write_char (A# buf) n# c# = + IO $ \ s# -> + case (writeCharOffAddr# buf n# c# s#) of s2# -> (# s2#, () #) + + shoveString :: Int# -> [Char] -> IO () + shoveString n ls = + case ls of + [] -> + if n ==# 0# then + CCALL(setBufWPtr) obj (0::Int) + else do + {- + At the end of a buffer write, update the buffer position + in the underlying file object, so that if the handle + is subsequently dropped by the program, the whole + buffer will be properly flushed. + + There's one case where this delayed up-date of the buffer + position can go wrong: if a thread is killed, it might be + in the middle of filling up a buffer, with the result that + the partial buffer update is lost upon finalisation. However, + by the time killThread is supported, Haskell finalisers are also + likely to be in, which means the 'IOFileObject' hack can go + alltogether. + + -} + CCALL(setBufWPtr) obj (I# n) + + ((C# x):xs) -> do + write_char buf n x + if n ==# bufLen + then do + rc <- mayBlock obj (CCALL(writeFileObject) obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block. + if rc == 0 + then shoveString 0# xs + else constructErrorAndFail "writeChunks" + else + shoveString (n +# 1#) xs + in + shoveString initPos# s +#endif /* ndef __HUGS__ */ #ifndef __PARALLEL_HASKELL__ - writeChars :: ForeignObj -> String -> IO Bool +writeChars :: ForeignObj -> String -> IO () #else - writeChars :: Addr -> String -> IO Bool +writeChars :: Addr -> String -> IO () #endif - writeChars fp "" = return True - writeChars fp (c:cs) = - _ccall_ filePutc fp (ord c) >>= \ rc -> - if rc == 0 then - writeChars fp cs - else - return False +writeChars fo "" = return () +writeChars fo (c:cs) = do + rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block. + if rc == 0 + then writeChars fo cs + else constructErrorAndFail "writeChars" + \end{code} -Computation $hPrint hdl t$ writes the string representation of {\em t} -given by the $shows$ function to the file or channel managed by {\em +Computation @hPrint hdl t@ writes the string representation of {\em t} +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. +[ Seem to have disappeared from the 1.4 interface - SOF 2/97 ] \begin{code} ---hPrint :: Show a => Handle -> a -> IO () -hPrint hdl = hPutStr hdl . show +hPrint :: Show a => Handle -> a -> IO () +hPrint hdl = hPutStrLn 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 :: Handle -> String -> IO () hPutStrLn hndl str = do hPutStr hndl str hPutChar hndl '\n' @@ -638,7 +633,7 @@ hPutStrLn hndl str = do %* * %********************************************************* -The construct $try comp$ exposes errors which occur within a +The construct @try comp@ exposes errors which occur within a computation, and which are not fully handled. It always succeeds. \begin{code} @@ -667,3 +662,63 @@ bracket_ before after m = do Left e -> fail e \end{code} +%********************************************************* +%* * +\subsection{Standard IO} +%* * +%********************************************************* + +The Prelude has from Day 1 provided a collection of common +IO functions. We define these here, but let the Prelude +export them. + +\begin{code} +putChar :: Char -> IO () +putChar c = hPutChar stdout c + +putStr :: String -> IO () +putStr s = hPutStr stdout s + +putStrLn :: String -> IO () +putStrLn s = do putStr s + putChar '\n' + +print :: Show a => a -> IO () +print x = putStrLn (show x) + +getChar :: IO Char +getChar = hGetChar stdin + +getLine :: IO String +getLine = hGetLine stdin + +getContents :: IO String +getContents = hGetContents stdin + +interact :: (String -> String) -> IO () +interact f = do s <- getContents + putStr (f s) + +readFile :: FilePath -> IO String +readFile name = openFile name ReadMode >>= hGetContents + +writeFile :: FilePath -> String -> IO () +writeFile name str = do + hdl <- openFile name WriteMode + hPutStr hdl str + hClose hdl + +appendFile :: FilePath -> String -> IO () +appendFile name str = do + hdl <- openFile name AppendMode + hPutStr hdl str + hClose hdl + +readLn :: Read a => IO a +readLn = do l <- getLine + r <- readIO l + return r + +#endif /* ndef HEAD */ + +\end{code}