1 % ------------------------------------------------------------------------------
2 % $Id: PrelIO.lhs,v 1.17 2001/01/11 07:04:16 qrczak 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(..) )
29 import PrelAddr ( Addr(..), nullAddr, plusAddr )
30 import PrelList ( concat, reverse, null )
31 import PrelPack ( unpackNBytesST, unpackNBytesAccST )
32 import PrelException ( ioError, catch, catchException, throw )
37 %*********************************************************
39 \subsection{Standard IO}
41 %*********************************************************
43 The Prelude has from Day 1 provided a collection of common
44 IO functions. We define these here, but let the Prelude
48 putChar :: Char -> IO ()
49 putChar c = hPutChar stdout c
51 putStr :: String -> IO ()
52 putStr s = hPutStr stdout s
54 putStrLn :: String -> IO ()
55 putStrLn s = do putStr s
58 print :: Show a => a -> IO ()
59 print x = putStrLn (show x)
62 getChar = hGetChar stdin
65 getLine = hGetLine stdin
67 getContents :: IO String
68 getContents = hGetContents stdin
70 interact :: (String -> String) -> IO ()
71 interact f = do s <- getContents
74 readFile :: FilePath -> IO String
75 readFile name = openFile name ReadMode >>= hGetContents
77 writeFile :: FilePath -> String -> IO ()
78 writeFile name str = do
79 hdl <- openFile name WriteMode
83 appendFile :: FilePath -> String -> IO ()
84 appendFile name str = do
85 hdl <- openFile name AppendMode
89 readLn :: Read a => IO a
90 readLn = do l <- getLine
96 %*********************************************************
98 \subsection{Simple input operations}
100 %*********************************************************
102 Computation @hReady hdl@ indicates whether at least
103 one item is available for input from handle {\em hdl}.
105 @hWaitForInput@ is the generalisation, wait for \tr{n} milliseconds
106 before deciding whether the Handle has run dry or not.
108 If @hWaitForInput@ finds anything in the Handle's buffer, it immediately returns.
109 If not, it tries to read from the underlying OS handle. Notice that
110 for buffered Handles connected to terminals this means waiting until a complete
114 hReady :: Handle -> IO Bool
115 hReady h = hWaitForInput h 0
117 hWaitForInput :: Handle -> Int -> IO Bool
118 hWaitForInput handle msecs =
119 wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do
120 rc <- inputReady (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block
124 _ -> constructErrorAndFail "hWaitForInput"
127 @hGetChar hdl@ reads the next character from handle @hdl@,
128 blocking until a character is available.
131 hGetChar :: Handle -> IO Char
133 c <- mayBlockRead "hGetChar" handle fileGetc
137 If EOF is reached before EOL is encountered, ignore the
138 EOF and return the partial line. Next attempt at calling
139 hGetLine on the handle will yield an EOF IO exception though.
142 hGetLine :: Handle -> IO String
144 buffer_mode <- wantReadableHandle "hGetLine" h
145 (\ handle_ -> do return (haBufferMode__ handle_))
147 NoBuffering -> hGetLineUnBuffered h
148 LineBuffering -> hGetLineBuf' []
149 BlockBuffering _ -> hGetLineBuf' []
151 where hGetLineBuf' xss = do
154 mayBlockRead' "hGetLine" h
157 buf <- getBufStart fo bytes
158 eol <- readCharOffAddr buf (bytes-1)
159 xs <- if (eol == '\n')
160 then stToIO (unpackNBytesST buf (bytes-1))
161 else stToIO (unpackNBytesST buf bytes)
165 (\e -> if isEOFError e && not (null xss)
166 then return ('\n', xss)
170 then return (concat (reverse xss))
171 else hGetLineBuf' xss
174 hGetLineUnBuffered :: Handle -> IO String
175 hGetLineUnBuffered h = do
188 if isEOFError err then
199 readCharOffAddr (A# a) (I# i)
200 = IO $ \s -> case readCharOffAddr# a i s of { (# s,x #) -> (# s, C# x #) }
203 @hLookahead hdl@ returns the next character from handle @hdl@
204 without removing it from the input buffer, blocking until a
205 character is available.
208 hLookAhead :: Handle -> IO Char
209 hLookAhead handle = do
210 rc <- mayBlockRead "hLookAhead" handle fileLookAhead
215 %*********************************************************
217 \subsection{Getting the entire contents of a handle}
219 %*********************************************************
221 @hGetContents hdl@ returns the list of characters corresponding
222 to the unread portion of the channel or file managed by @hdl@,
223 which is made semi-closed.
226 hGetContents :: Handle -> IO String
227 hGetContents handle =
228 -- can't use wantReadableHandle here, because we want to side effect
230 withHandle handle $ \ handle_ -> do
231 case haType__ handle_ of
232 ClosedHandle -> ioe_closedHandle "hGetContents" handle
233 SemiClosedHandle -> ioe_closedHandle "hGetContents" handle
234 AppendHandle -> ioException not_readable_error
235 WriteHandle -> ioException not_readable_error
238 To avoid introducing an extra layer of buffering here,
239 we provide three lazy read methods, based on character,
240 line, and block buffering.
242 let handle_' = handle_{ haType__ = SemiClosedHandle }
243 case (haBufferMode__ handle_) of
245 str <- unsafeInterleaveIO (lazyReadLine handle (haFO__ handle_))
246 return (handle_', str)
247 BlockBuffering _ -> do
248 str <- unsafeInterleaveIO (lazyReadBlock handle (haFO__ handle_))
249 return (handle_', str)
251 str <- unsafeInterleaveIO (lazyReadChar handle (haFO__ handle_))
252 return (handle_', str)
255 IOError (Just handle) IllegalOperation "hGetContents"
256 "handle is not open for reading" Nothing
259 Note that someone may close the semi-closed handle (or change its buffering),
260 so each these lazy read functions are pulled on, they have to check whether
261 the handle has indeed been closed.
264 #ifndef __PARALLEL_HASKELL__
265 lazyReadBlock :: Handle -> ForeignObj -> IO String
266 lazyReadLine :: Handle -> ForeignObj -> IO String
267 lazyReadChar :: Handle -> ForeignObj -> IO String
269 lazyReadBlock :: Handle -> Addr -> IO String
270 lazyReadLine :: Handle -> Addr -> IO String
271 lazyReadChar :: Handle -> Addr -> IO String
274 lazyReadBlock handle fo = do
275 buf <- getBufStart fo 0
276 bytes <- mayBlock fo (readBlock fo) -- ConcHask: UNSAFE, may block.
278 -3 -> -- buffering has been turned off, use lazyReadChar instead
279 lazyReadChar handle fo
281 -1 -> -- an error occurred, close the handle
282 withHandle handle $ \ handle_ -> do
283 closeFile (haFO__ handle_) 0{-don't bother flushing-} -- ConcHask: SAFE, won't block.
284 return (handle_ { haType__ = ClosedHandle }, "")
286 more <- unsafeInterleaveIO (lazyReadBlock handle fo)
287 stToIO (unpackNBytesAccST buf bytes more)
289 lazyReadLine handle fo = do
290 bytes <- mayBlock fo (readLine fo) -- ConcHask: UNSAFE, may block.
292 -3 -> -- buffering has been turned off, use lazyReadChar instead
293 lazyReadChar handle fo
294 -2 -> return "" -- handle closed by someone else, stop reading.
295 -1 -> -- an error occurred, close the handle
296 withHandle handle $ \ handle_ -> do
297 closeFile (haFO__ handle_) 0{- don't bother flushing-} -- ConcHask: SAFE, won't block
298 return (handle_ { haType__ = ClosedHandle }, "")
300 more <- unsafeInterleaveIO (lazyReadLine handle fo)
301 buf <- getBufStart fo bytes -- ConcHask: won't block
302 stToIO (unpackNBytesAccST buf bytes more)
304 lazyReadChar handle fo = do
305 char <- mayBlock fo (readChar fo) -- ConcHask: UNSAFE, may block.
307 -4 -> -- buffering is now block-buffered, use lazyReadBlock instead
308 lazyReadBlock handle fo
310 -3 -> -- buffering is now line-buffered, use lazyReadLine instead
311 lazyReadLine handle fo
313 -1 -> -- error, silently close handle.
314 withHandle handle $ \ handle_ -> do
315 closeFile (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block
316 return (handle_{ haType__ = ClosedHandle }, "")
318 more <- unsafeInterleaveIO (lazyReadChar handle fo)
319 return (chr char : more)
324 %*********************************************************
326 \subsection{Simple output functions}
328 %*********************************************************
330 @hPutChar hdl ch@ writes the character @ch@ to the file
331 or channel managed by @hdl@. Characters may be buffered if
332 buffering is enabled for @hdl@
335 hPutChar :: Handle -> Char -> IO ()
337 c `seq` do -- must evaluate c before grabbing the handle lock
338 wantWriteableHandle "hPutChar" handle $ \ handle_ -> do
339 let fo = haFO__ handle_
341 rc <- mayBlock fo (filePutc fo c) -- ConcHask: UNSAFE, may block.
344 else constructErrorAndFail "hPutChar"
346 hPutChars :: Handle -> [Char] -> IO ()
347 hPutChars handle [] = return ()
348 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
351 @hPutStr hdl s@ writes the string @s@ to the file or
352 channel managed by @hdl@, buffering the output if needs be.
356 hPutStr :: Handle -> String -> IO ()
357 hPutStr handle str = do
358 buffer_mode <- wantWriteableHandle_ "hPutStr" handle
359 (\ handle_ -> do getBuffer handle_)
361 (NoBuffering, _, _) -> do
362 hPutChars handle str -- v. slow, but we don't care
363 (LineBuffering, buf, bsz) -> do
364 writeLines handle buf bsz str
365 (BlockBuffering _, buf, bsz) -> do
366 writeBlocks handle buf bsz str
367 -- ToDo: async exceptions during writeLines & writeBlocks will cause
368 -- the buffer to get lost in the void. Using ByteArrays instead of
369 -- malloced buffers is one way around this, but we really ought to
370 -- be able to handle it with exception handlers/block/unblock etc.
372 getBuffer :: Handle__ -> IO (Handle__, (BufferMode, Addr, Int))
373 getBuffer handle_ = do
374 let bufs = haBuffers__ handle_
376 mode = haBufferMode__ handle_
379 NoBuffering -> return (handle_, (mode, nullAddr, 0))
381 [] -> do buf <- malloc sz
382 return (handle_, (mode, buf, sz))
383 (b:bs) -> return (handle_{ haBuffers__ = bs }, (mode, b, sz))
385 freeBuffer :: Handle__ -> Addr -> Int -> IO Handle__
386 freeBuffer handle_ buf sz = do
387 fo_sz <- getBufSize (haFO__ handle_)
389 then do { free buf; return handle_ }
390 else do { return handle_{ haBuffers__ = buf : haBuffers__ handle_ } }
392 swapBuffers :: Handle__ -> Addr -> Int -> IO Handle__
393 swapBuffers handle_ buf sz = do
394 let fo = haFO__ handle_
397 return (handle_{ haBuffers__ = fo_buf : haBuffers__ handle_ })
399 -------------------------------------------------------------------------------
400 -- commitAndReleaseBuffer handle buf sz count flush
402 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
403 -- 'count' bytes of data) to handle (handle must be block or line buffered).
407 -- for block/line buffering,
408 -- 1. If there isn't room in the handle buffer, flush the handle
411 -- 2. If the handle buffer is empty,
413 -- then write buf directly to the device.
414 -- else swap the handle buffer with buf.
416 -- 3. If the handle buffer is non-empty, copy buf into the
417 -- handle buffer. Then, if flush != 0, flush
420 commitAndReleaseBuffer
421 :: Handle -- handle to commit to
422 -> Addr -> Int -- address and size (in bytes) of buffer
423 -> Int -- number of bytes of data in buffer
424 -> Bool -- flush the handle afterward?
427 commitAndReleaseBuffer hdl@(Handle h) buf sz count flush = do
430 -- First deal with any possible exceptions, by freeing the buffer.
431 -- Async exceptions are blocked, but there are still some interruptible
434 -- note that commit doesn't *always* free the buffer, it might
435 -- swap it for the current handle buffer instead. This makes things
436 -- a whole lot more complicated, because we can't just do
437 -- "finally (... free buffer ...)" here.
438 catchException (commit hdl h_)
439 (\e -> do { h_ <- freeBuffer h_ buf sz; putMVar h h_ })
442 commit hdl@(Handle h) handle_ =
443 checkWriteableHandle "commitAndReleaseBuffer" hdl handle_ $ do
444 let fo = haFO__ handle_
445 flushConnectedBuf fo -- ???? -SDM
446 getWriteableBuf fo -- flush read buf if necessary
448 fo_wptr <- getBufWPtr fo
449 fo_bufSize <- getBufSize fo
451 let ok h_ = putMVar h h_ >> return ()
453 -- enough room in handle buffer for the new data?
454 if (flush || fo_bufSize - fo_wptr <= count)
456 -- The <= is to be sure that we never exactly fill up the
457 -- buffer, which would require a flush. So if copying the
458 -- new data into the buffer would make the buffer full, we
459 -- just flush the existing buffer and the new data immediately,
460 -- rather than copying before flushing.
462 then do rc <- mayBlock fo (flushFile fo)
464 then constructErrorAndFail "commitAndReleaseBuffer"
466 if (flush || sz /= fo_bufSize || count == sz)
467 then do rc <- write_buf fo buf count
469 then constructErrorAndFail "commitAndReleaseBuffer"
470 else do handle_ <- freeBuffer handle_ buf sz
473 -- if: (a) we don't have to flush, and
474 -- (b) size(new buffer) == size(old buffer), and
475 -- (c) new buffer is not full,
476 -- we can just just swap them over...
477 else do handle_ <- swapBuffers handle_ buf sz
481 -- not flushing, and there's enough room in the buffer:
482 -- just copy the data in and update bufWPtr.
483 else do memcpy (plusAddr fo_buf fo_wptr) buf count
484 setBufWPtr fo (fo_wptr + count)
485 handle_ <- freeBuffer handle_ buf sz
488 --------------------------------------------------------------------------------
489 -- commitBuffer handle buf sz count flush
491 -- Flushes 'count' bytes from the buffer 'buf' (size 'sz') to 'handle'.
492 -- There are several cases to consider altogether:
495 -- - flush handle buffer,
496 -- - write out new buffer directly
499 -- - if there's enough room in the handle buffer,
500 -- then copy new buf into it
501 -- else flush handle buffer, then copy new buffer into it
503 -- Make sure that we maintain the invariant that the handle buffer is never
504 -- left in a full state. Several functions rely on this (eg. filePutc), so
505 -- if we're about to exactly fill the buffer then we make sure we do a flush
506 -- here (also see above in commitAndReleaseBuffer).
509 :: Handle -- handle to commit to
510 -> Addr -> Int -- address and size (in bytes) of buffer
511 -> Int -- number of bytes of data in buffer
512 -> Bool -- flush the handle afterward?
515 commitBuffer handle buf sz count flush = do
516 wantWriteableHandle "commitBuffer" handle $ \handle_ -> do
517 let fo = haFO__ handle_
518 flushConnectedBuf fo -- ???? -SDM
519 getWriteableBuf fo -- flush read buf if necessary
521 fo_wptr <- getBufWPtr fo
522 fo_bufSize <- getBufSize fo
524 new_wptr <- -- not enough room in handle buffer?
525 (if flush || (fo_bufSize - fo_wptr <= count)
526 then do rc <- mayBlock fo (flushFile fo)
527 if (rc < 0) then constructErrorAndFail "commitBuffer"
529 else return fo_wptr )
531 if (flush || fo_bufSize <= count) -- committed buffer too large?
533 then do rc <- write_buf fo buf count
534 if (rc < 0) then constructErrorAndFail "commitBuffer"
537 else do memcpy (plusAddr fo_buf new_wptr) buf count
538 setBufWPtr fo (new_wptr + count)
541 write_buf fo buf 0 = return 0
542 write_buf fo buf count = do
543 rc <- mayBlock fo (write_ fo buf count)
545 then write_buf fo buf (count - rc) -- partial write
548 -- a version of commitBuffer that will free the buffer if an exception is
549 -- received. DON'T use this if you intend to use the buffer again!
550 checkedCommitBuffer handle buf sz count flush
551 = catchException (commitBuffer handle buf sz count flush)
552 (\e -> do withHandle__ handle (\h_ -> freeBuffer h_ buf sz)
555 foreign import "memcpy" unsafe memcpy :: Addr -> Addr -> Int -> IO ()
558 Going across the border between Haskell and C is relatively costly,
559 so for block writes we pack the character strings on the Haskell-side
560 before passing the external write routine a pointer to the buffer.
565 #ifdef __CONCURRENT_HASKELL__
566 /* See comment in shoveString below for explanation */
567 #warning delayed update of buffer disnae work with killThread
570 writeLines :: Handle -> Addr -> Int -> String -> IO ()
571 writeLines handle buf bufLen s =
573 shoveString :: Int -> [Char] -> IO ()
576 [] -> commitAndReleaseBuffer handle buf buflen n False{-no need to flush-}
579 primWriteCharOffAddr buf n x
580 {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
582 if next_n == bufLen || x == '\n'
584 checkedCommitBuffer hdl buf len next_n True{-needs flush-}
587 shoveString next_n xs
591 #else /* ndef __HUGS__ */
593 writeLines :: Handle -> Addr -> Int -> String -> IO ()
594 writeLines hdl buf len@(I# bufLen) s =
596 shoveString :: Int# -> [Char] -> IO ()
599 [] -> commitAndReleaseBuffer hdl buf len (I# n) False{-no need to flush-}
603 -- Flushing on buffer exhaustion or newlines
604 -- (even if it isn't the last one)
606 if next_n ==# bufLen || x `eqChar#` '\n'#
608 checkedCommitBuffer hdl buf len (I# next_n) True{-needs flush-}
611 shoveString next_n xs
614 #endif /* ndef __HUGS__ */
617 writeBlocks :: Handle -> Addr -> Int -> String -> IO ()
618 writeBlocks hdl buf bufLen s =
620 shoveString :: Int -> [Char] -> IO ()
623 [] -> commitAndReleaseBuffer hdl buf len n False{-no need to flush-}
626 primWriteCharOffAddr buf n x
630 checkedCommitBuffer hdl buf len next_n True{-needs flush-}
633 shoveString next_n xs
637 #else /* ndef __HUGS__ */
639 writeBlocks :: Handle -> Addr -> Int -> String -> IO ()
640 writeBlocks hdl buf len@(I# bufLen) s =
642 shoveString :: Int# -> [Char] -> IO ()
645 [] -> commitAndReleaseBuffer hdl buf len (I# n) False{-no need to flush-}
652 checkedCommitBuffer hdl buf len (I# next_n) True{-needs flush-}
655 shoveString next_n xs
659 write_char :: Addr -> Int# -> Char# -> IO ()
660 write_char (A# buf#) n# c# =
662 case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
663 #endif /* ndef __HUGS__ */
666 Computation @hPrint hdl t@ writes the string representation of {\em t}
667 given by the @shows@ function to the file or channel managed by {\em
670 [ Seem to have disappeared from the 1.4 interface - SOF 2/97 ]
673 hPrint :: Show a => Handle -> a -> IO ()
674 hPrint hdl = hPutStrLn hdl . show
677 Derived action @hPutStrLn hdl str@ writes the string \tr{str} to
678 the handle \tr{hdl}, adding a newline at the end.
681 hPutStrLn :: Handle -> String -> IO ()
682 hPutStrLn hndl str = do