1 % ------------------------------------------------------------------------------
2 % $Id: PrelIO.lhs,v 1.18 2001/01/11 17:25:57 simonmar Exp $
4 % (c) The University of Glasgow, 1992-2000
7 \section[PrelIO]{Module @PrelIO@}
9 This module defines all basic IO operations.
10 These are needed for the IO operations exported by Prelude,
11 but as it happens they also do everything required by library
16 {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
23 import PrelHandle -- much of the real stuff is in here
26 import PrelRead ( Read(..), readIO )
28 import PrelMaybe ( Maybe(..) )
30 import PrelList ( concat, reverse, null )
31 import PrelPack ( unpackNBytesST, unpackNBytesAccST )
32 import PrelException ( ioError, catch, catchException, throw )
35 #ifndef __PARALLEL_HASKELL__
36 #define FILE_OBJECT (ForeignPtr ())
38 #define FILE_OBJECT (Ptr ())
42 %*********************************************************
44 \subsection{Standard IO}
46 %*********************************************************
48 The Prelude has from Day 1 provided a collection of common
49 IO functions. We define these here, but let the Prelude
53 putChar :: Char -> IO ()
54 putChar c = hPutChar stdout c
56 putStr :: String -> IO ()
57 putStr s = hPutStr stdout s
59 putStrLn :: String -> IO ()
60 putStrLn s = do putStr s
63 print :: Show a => a -> IO ()
64 print x = putStrLn (show x)
67 getChar = hGetChar stdin
70 getLine = hGetLine stdin
72 getContents :: IO String
73 getContents = hGetContents stdin
75 interact :: (String -> String) -> IO ()
76 interact f = do s <- getContents
79 readFile :: FilePath -> IO String
80 readFile name = openFile name ReadMode >>= hGetContents
82 writeFile :: FilePath -> String -> IO ()
83 writeFile name str = do
84 hdl <- openFile name WriteMode
88 appendFile :: FilePath -> String -> IO ()
89 appendFile name str = do
90 hdl <- openFile name AppendMode
94 readLn :: Read a => IO a
95 readLn = do l <- getLine
101 %*********************************************************
103 \subsection{Simple input operations}
105 %*********************************************************
107 Computation @hReady hdl@ indicates whether at least
108 one item is available for input from handle {\em hdl}.
110 @hWaitForInput@ is the generalisation, wait for \tr{n} milliseconds
111 before deciding whether the Handle has run dry or not.
113 If @hWaitForInput@ finds anything in the Handle's buffer, it immediately returns.
114 If not, it tries to read from the underlying OS handle. Notice that
115 for buffered Handles connected to terminals this means waiting until a complete
119 hReady :: Handle -> IO Bool
120 hReady h = hWaitForInput h 0
122 hWaitForInput :: Handle -> Int -> IO Bool
123 hWaitForInput handle msecs =
124 wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do
125 rc <- inputReady (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block
129 _ -> constructErrorAndFail "hWaitForInput"
132 @hGetChar hdl@ reads the next character from handle @hdl@,
133 blocking until a character is available.
136 hGetChar :: Handle -> IO Char
138 c <- mayBlockRead "hGetChar" handle fileGetc
142 If EOF is reached before EOL is encountered, ignore the
143 EOF and return the partial line. Next attempt at calling
144 hGetLine on the handle will yield an EOF IO exception though.
147 hGetLine :: Handle -> IO String
149 buffer_mode <- wantReadableHandle "hGetLine" h
150 (\ handle_ -> do return (haBufferMode__ handle_))
152 NoBuffering -> hGetLineUnBuffered h
153 LineBuffering -> hGetLineBuf' []
154 BlockBuffering _ -> hGetLineBuf' []
156 where hGetLineBuf' xss = do
159 mayBlockRead' "hGetLine" h
162 buf <- getBufStart fo bytes
163 eol <- readCharOffPtr buf (bytes-1)
164 xs <- if (eol == '\n')
165 then stToIO (unpackNBytesST buf (bytes-1))
166 else stToIO (unpackNBytesST buf bytes)
170 (\e -> if isEOFError e && not (null xss)
171 then return ('\n', xss)
175 then return (concat (reverse xss))
176 else hGetLineBuf' xss
179 hGetLineUnBuffered :: Handle -> IO String
180 hGetLineUnBuffered h = do
193 if isEOFError err then
204 readCharOffPtr (Ptr a) (I# i)
205 = IO $ \s -> case readCharOffAddr# a i s of { (# s,x #) -> (# s, C# x #) }
208 @hLookahead hdl@ returns the next character from handle @hdl@
209 without removing it from the input buffer, blocking until a
210 character is available.
213 hLookAhead :: Handle -> IO Char
214 hLookAhead handle = do
215 rc <- mayBlockRead "hLookAhead" handle fileLookAhead
220 %*********************************************************
222 \subsection{Getting the entire contents of a handle}
224 %*********************************************************
226 @hGetContents hdl@ returns the list of characters corresponding
227 to the unread portion of the channel or file managed by @hdl@,
228 which is made semi-closed.
231 hGetContents :: Handle -> IO String
232 hGetContents handle =
233 -- can't use wantReadableHandle here, because we want to side effect
235 withHandle handle $ \ handle_ -> do
236 case haType__ handle_ of
237 ClosedHandle -> ioe_closedHandle "hGetContents" handle
238 SemiClosedHandle -> ioe_closedHandle "hGetContents" handle
239 AppendHandle -> ioException not_readable_error
240 WriteHandle -> ioException not_readable_error
243 To avoid introducing an extra layer of buffering here,
244 we provide three lazy read methods, based on character,
245 line, and block buffering.
247 let handle_' = handle_{ haType__ = SemiClosedHandle }
248 case (haBufferMode__ handle_) of
250 str <- unsafeInterleaveIO (lazyReadLine handle (haFO__ handle_))
251 return (handle_', str)
252 BlockBuffering _ -> do
253 str <- unsafeInterleaveIO (lazyReadBlock handle (haFO__ handle_))
254 return (handle_', str)
256 str <- unsafeInterleaveIO (lazyReadChar handle (haFO__ handle_))
257 return (handle_', str)
260 IOError (Just handle) IllegalOperation "hGetContents"
261 "handle is not open for reading" Nothing
264 Note that someone may close the semi-closed handle (or change its buffering),
265 so each these lazy read functions are pulled on, they have to check whether
266 the handle has indeed been closed.
269 lazyReadBlock :: Handle -> FILE_OBJECT -> IO String
270 lazyReadLine :: Handle -> FILE_OBJECT -> IO String
271 lazyReadChar :: Handle -> FILE_OBJECT -> IO String
273 lazyReadBlock handle fo = do
274 buf <- getBufStart fo 0
275 bytes <- mayBlock fo (readBlock fo) -- ConcHask: UNSAFE, may block.
277 -3 -> -- buffering has been turned off, use lazyReadChar instead
278 lazyReadChar handle fo
280 -1 -> -- an error occurred, close the handle
281 withHandle handle $ \ handle_ -> do
282 closeFile (haFO__ handle_) 0{-don't bother flushing-} -- ConcHask: SAFE, won't block.
283 return (handle_ { haType__ = ClosedHandle }, "")
285 more <- unsafeInterleaveIO (lazyReadBlock handle fo)
286 stToIO (unpackNBytesAccST buf bytes more)
288 lazyReadLine handle fo = do
289 bytes <- mayBlock fo (readLine fo) -- ConcHask: UNSAFE, may block.
291 -3 -> -- buffering has been turned off, use lazyReadChar instead
292 lazyReadChar handle fo
293 -2 -> return "" -- handle closed by someone else, stop reading.
294 -1 -> -- an error occurred, close the handle
295 withHandle handle $ \ handle_ -> do
296 closeFile (haFO__ handle_) 0{- don't bother flushing-} -- ConcHask: SAFE, won't block
297 return (handle_ { haType__ = ClosedHandle }, "")
299 more <- unsafeInterleaveIO (lazyReadLine handle fo)
300 buf <- getBufStart fo bytes -- ConcHask: won't block
301 stToIO (unpackNBytesAccST buf bytes more)
303 lazyReadChar handle fo = do
304 char <- mayBlock fo (readChar fo) -- ConcHask: UNSAFE, may block.
306 -4 -> -- buffering is now block-buffered, use lazyReadBlock instead
307 lazyReadBlock handle fo
309 -3 -> -- buffering is now line-buffered, use lazyReadLine instead
310 lazyReadLine handle fo
312 -1 -> -- error, silently close handle.
313 withHandle handle $ \ handle_ -> do
314 closeFile (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block
315 return (handle_{ haType__ = ClosedHandle }, "")
317 more <- unsafeInterleaveIO (lazyReadChar handle fo)
318 return (chr char : more)
323 %*********************************************************
325 \subsection{Simple output functions}
327 %*********************************************************
329 @hPutChar hdl ch@ writes the character @ch@ to the file
330 or channel managed by @hdl@. Characters may be buffered if
331 buffering is enabled for @hdl@
334 hPutChar :: Handle -> Char -> IO ()
336 c `seq` do -- must evaluate c before grabbing the handle lock
337 wantWriteableHandle "hPutChar" handle $ \ handle_ -> do
338 let fo = haFO__ handle_
340 rc <- mayBlock fo (filePutc fo c) -- ConcHask: UNSAFE, may block.
343 else constructErrorAndFail "hPutChar"
345 hPutChars :: Handle -> [Char] -> IO ()
346 hPutChars handle [] = return ()
347 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
350 @hPutStr hdl s@ writes the string @s@ to the file or
351 channel managed by @hdl@, buffering the output if needs be.
355 hPutStr :: Handle -> String -> IO ()
356 hPutStr handle str = do
357 buffer_mode <- wantWriteableHandle_ "hPutStr" handle
358 (\ handle_ -> do getBuffer handle_)
360 (NoBuffering, _, _) -> do
361 hPutChars handle str -- v. slow, but we don't care
362 (LineBuffering, buf, bsz) -> do
363 writeLines handle buf bsz str
364 (BlockBuffering _, buf, bsz) -> do
365 writeBlocks handle buf bsz str
366 -- ToDo: async exceptions during writeLines & writeBlocks will cause
367 -- the buffer to get lost in the void. Using ByteArrays instead of
368 -- malloced buffers is one way around this, but we really ought to
369 -- be able to handle it with exception handlers/block/unblock etc.
371 getBuffer :: Handle__ -> IO (Handle__, (BufferMode, Ptr (), Int))
372 getBuffer handle_ = do
373 let bufs = haBuffers__ handle_
375 mode = haBufferMode__ handle_
378 NoBuffering -> return (handle_, (mode, nullPtr, 0))
380 [] -> do buf <- malloc sz
381 return (handle_, (mode, buf, sz))
382 (b:bs) -> return (handle_{ haBuffers__ = bs }, (mode, b, sz))
384 freeBuffer :: Handle__ -> Ptr () -> Int -> IO Handle__
385 freeBuffer handle_ buf sz = do
386 fo_sz <- getBufSize (haFO__ handle_)
388 then do { free buf; return handle_ }
389 else do { return handle_{ haBuffers__ = buf : haBuffers__ handle_ } }
391 swapBuffers :: Handle__ -> Ptr () -> Int -> IO Handle__
392 swapBuffers handle_ buf sz = do
393 let fo = haFO__ handle_
396 return (handle_{ haBuffers__ = fo_buf : haBuffers__ handle_ })
398 -------------------------------------------------------------------------------
399 -- commitAndReleaseBuffer handle buf sz count flush
401 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
402 -- 'count' bytes of data) to handle (handle must be block or line buffered).
406 -- for block/line buffering,
407 -- 1. If there isn't room in the handle buffer, flush the handle
410 -- 2. If the handle buffer is empty,
412 -- then write buf directly to the device.
413 -- else swap the handle buffer with buf.
415 -- 3. If the handle buffer is non-empty, copy buf into the
416 -- handle buffer. Then, if flush != 0, flush
419 commitAndReleaseBuffer
420 :: Handle -- handle to commit to
421 -> Ptr () -> Int -- address and size (in bytes) of buffer
422 -> Int -- number of bytes of data in buffer
423 -> Bool -- flush the handle afterward?
426 commitAndReleaseBuffer hdl@(Handle h) buf sz count flush = do
429 -- First deal with any possible exceptions, by freeing the buffer.
430 -- Async exceptions are blocked, but there are still some interruptible
433 -- note that commit doesn't *always* free the buffer, it might
434 -- swap it for the current handle buffer instead. This makes things
435 -- a whole lot more complicated, because we can't just do
436 -- "finally (... free buffer ...)" here.
437 catchException (commit hdl h_)
438 (\e -> do { h_ <- freeBuffer h_ buf sz; putMVar h h_ })
441 commit hdl@(Handle h) handle_ =
442 checkWriteableHandle "commitAndReleaseBuffer" hdl handle_ $ do
443 let fo = haFO__ handle_
444 flushConnectedBuf fo -- ???? -SDM
445 getWriteableBuf fo -- flush read buf if necessary
447 fo_wptr <- getBufWPtr fo
448 fo_bufSize <- getBufSize fo
450 let ok h_ = putMVar h h_ >> return ()
452 -- enough room in handle buffer for the new data?
453 if (flush || fo_bufSize - fo_wptr <= count)
455 -- The <= is to be sure that we never exactly fill up the
456 -- buffer, which would require a flush. So if copying the
457 -- new data into the buffer would make the buffer full, we
458 -- just flush the existing buffer and the new data immediately,
459 -- rather than copying before flushing.
461 then do rc <- mayBlock fo (flushFile fo)
463 then constructErrorAndFail "commitAndReleaseBuffer"
465 if (flush || sz /= fo_bufSize || count == sz)
466 then do rc <- write_buf fo buf count
468 then constructErrorAndFail "commitAndReleaseBuffer"
469 else do handle_ <- freeBuffer handle_ buf sz
472 -- if: (a) we don't have to flush, and
473 -- (b) size(new buffer) == size(old buffer), and
474 -- (c) new buffer is not full,
475 -- we can just just swap them over...
476 else do handle_ <- swapBuffers handle_ buf sz
480 -- not flushing, and there's enough room in the buffer:
481 -- just copy the data in and update bufWPtr.
482 else do memcpy (plusPtr fo_buf fo_wptr) buf count
483 setBufWPtr fo (fo_wptr + count)
484 handle_ <- freeBuffer handle_ buf sz
487 --------------------------------------------------------------------------------
488 -- commitBuffer handle buf sz count flush
490 -- Flushes 'count' bytes from the buffer 'buf' (size 'sz') to 'handle'.
491 -- There are several cases to consider altogether:
494 -- - flush handle buffer,
495 -- - write out new buffer directly
498 -- - if there's enough room in the handle buffer,
499 -- then copy new buf into it
500 -- else flush handle buffer, then copy new buffer into it
502 -- Make sure that we maintain the invariant that the handle buffer is never
503 -- left in a full state. Several functions rely on this (eg. filePutc), so
504 -- if we're about to exactly fill the buffer then we make sure we do a flush
505 -- here (also see above in commitAndReleaseBuffer).
508 :: Handle -- handle to commit to
509 -> Ptr () -> Int -- address and size (in bytes) of buffer
510 -> Int -- number of bytes of data in buffer
511 -> Bool -- flush the handle afterward?
514 commitBuffer handle buf sz count flush = do
515 wantWriteableHandle "commitBuffer" handle $ \handle_ -> do
516 let fo = haFO__ handle_
517 flushConnectedBuf fo -- ???? -SDM
518 getWriteableBuf fo -- flush read buf if necessary
520 fo_wptr <- getBufWPtr fo
521 fo_bufSize <- getBufSize fo
523 new_wptr <- -- not enough room in handle buffer?
524 (if flush || (fo_bufSize - fo_wptr <= count)
525 then do rc <- mayBlock fo (flushFile fo)
526 if (rc < 0) then constructErrorAndFail "commitBuffer"
528 else return fo_wptr )
530 if (flush || fo_bufSize <= count) -- committed buffer too large?
532 then do rc <- write_buf fo buf count
533 if (rc < 0) then constructErrorAndFail "commitBuffer"
536 else do memcpy (plusPtr fo_buf new_wptr) buf count
537 setBufWPtr fo (new_wptr + count)
540 write_buf fo buf 0 = return 0
541 write_buf fo buf count = do
542 rc <- mayBlock fo (write_ fo buf count)
544 then write_buf fo buf (count - rc) -- partial write
547 -- a version of commitBuffer that will free the buffer if an exception is
548 -- received. DON'T use this if you intend to use the buffer again!
549 checkedCommitBuffer handle buf sz count flush
550 = catchException (commitBuffer handle buf sz count flush)
551 (\e -> do withHandle__ handle (\h_ -> freeBuffer h_ buf sz)
554 foreign import "memcpy" unsafe memcpy :: Ptr () -> Ptr () -> Int -> IO ()
557 Going across the border between Haskell and C is relatively costly,
558 so for block writes we pack the character strings on the Haskell-side
559 before passing the external write routine a pointer to the buffer.
564 #ifdef __CONCURRENT_HASKELL__
565 /* See comment in shoveString below for explanation */
566 #warning delayed update of buffer disnae work with killThread
569 writeLines :: Handle -> Ptr () -> Int -> String -> IO ()
570 writeLines handle buf bufLen s =
572 shoveString :: Int -> [Char] -> IO ()
575 [] -> commitAndReleaseBuffer handle buf buflen n False{-no need to flush-}
578 primWriteCharOffAddr buf n x
579 {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
581 if next_n == bufLen || x == '\n'
583 checkedCommitBuffer hdl buf len next_n True{-needs flush-}
586 shoveString next_n xs
590 #else /* ndef __HUGS__ */
592 writeLines :: Handle -> Ptr () -> Int -> String -> IO ()
593 writeLines hdl buf len@(I# bufLen) s =
595 shoveString :: Int# -> [Char] -> IO ()
598 [] -> commitAndReleaseBuffer hdl buf len (I# n) False{-no need to flush-}
602 -- Flushing on buffer exhaustion or newlines
603 -- (even if it isn't the last one)
605 if next_n ==# bufLen || x `eqChar#` '\n'#
607 checkedCommitBuffer hdl buf len (I# next_n) True{-needs flush-}
610 shoveString next_n xs
613 #endif /* ndef __HUGS__ */
616 writeBlocks :: Handle -> Ptr () -> Int -> String -> IO ()
617 writeBlocks hdl buf bufLen s =
619 shoveString :: Int -> [Char] -> IO ()
622 [] -> commitAndReleaseBuffer hdl buf len n False{-no need to flush-}
625 primWriteCharOffAddr buf n x
629 checkedCommitBuffer hdl buf len next_n True{-needs flush-}
632 shoveString next_n xs
636 #else /* ndef __HUGS__ */
638 writeBlocks :: Handle -> Ptr () -> Int -> String -> IO ()
639 writeBlocks hdl buf len@(I# bufLen) s =
641 shoveString :: Int# -> [Char] -> IO ()
644 [] -> commitAndReleaseBuffer hdl buf len (I# n) False{-no need to flush-}
651 checkedCommitBuffer hdl buf len (I# next_n) True{-needs flush-}
654 shoveString next_n xs
658 write_char :: Ptr () -> Int# -> Char# -> IO ()
659 write_char (Ptr buf#) n# c# =
661 case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
662 #endif /* ndef __HUGS__ */
665 Computation @hPrint hdl t@ writes the string representation of {\em t}
666 given by the @shows@ function to the file or channel managed by {\em
669 [ Seem to have disappeared from the 1.4 interface - SOF 2/97 ]
672 hPrint :: Show a => Handle -> a -> IO ()
673 hPrint hdl = hPutStrLn hdl . show
676 Derived action @hPutStrLn hdl str@ writes the string \tr{str} to
677 the handle \tr{hdl}, adding a newline at the end.
680 hPutStrLn :: Handle -> String -> IO ()
681 hPutStrLn hndl str = do