1 {-# OPTIONS -fno-implicit-prelude #-}
5 -- -----------------------------------------------------------------------------
6 -- $Id: PrelIO.hsc,v 1.14 2001/09/17 16:21:41 simonmar Exp $
8 -- (c) The University of Glasgow, 1992-2001
12 -- This module defines all basic IO operations.
13 -- These are needed for the IO operations exported by Prelude,
14 -- but as it happens they also do everything required by library
18 putChar, putStr, putStrLn, print, getChar, getLine, getContents,
19 interact, readFile, writeFile, appendFile, readLn, readIO, hReady,
20 hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
22 commitBuffer, commitBuffer'
26 #include "PrelHandle_hsc.h"
31 import PrelMarshalUtils
39 import PrelHandle -- much of the real stuff is in here
46 import PrelMaybe ( Maybe(..) )
49 import PrelException ( ioError, catch, throw )
52 -- -----------------------------------------------------------------------------
55 putChar :: Char -> IO ()
56 putChar c = hPutChar stdout c
58 putStr :: String -> IO ()
59 putStr s = hPutStr stdout s
61 putStrLn :: String -> IO ()
62 putStrLn s = do putStr s
65 print :: Show a => a -> IO ()
66 print x = putStrLn (show x)
69 getChar = hGetChar stdin
72 getLine = hGetLine stdin
74 getContents :: IO String
75 getContents = hGetContents stdin
77 interact :: (String -> String) -> IO ()
78 interact f = do s <- getContents
81 readFile :: FilePath -> IO String
82 readFile name = openFile name ReadMode >>= hGetContents
84 writeFile :: FilePath -> String -> IO ()
85 writeFile name str = do
86 hdl <- openFile name WriteMode
90 appendFile :: FilePath -> String -> IO ()
91 appendFile name str = do
92 hdl <- openFile name AppendMode
96 readLn :: Read a => IO a
97 readLn = do l <- getLine
101 -- raises an exception instead of an error
102 readIO :: Read a => String -> IO a
103 readIO s = case (do { (x,t) <- reads s ;
106 #ifndef NEW_READS_REP
108 [] -> ioError (userError "Prelude.readIO: no parse")
109 _ -> ioError (userError "Prelude.readIO: ambiguous parse")
112 Nothing -> ioError (userError "Prelude.readIO: no parse")
115 -- ---------------------------------------------------------------------------
116 -- Simple input operations
118 -- Computation "hReady hdl" indicates whether at least
119 -- one item is available for input from handle "hdl".
121 -- If hWaitForInput finds anything in the Handle's buffer, it
122 -- immediately returns. If not, it tries to read from the underlying
123 -- OS handle. Notice that for buffered Handles connected to terminals
124 -- this means waiting until a complete line is available.
126 hReady :: Handle -> IO Bool
127 hReady h = hWaitForInput h 0
129 hWaitForInput :: Handle -> Int -> IO Bool
130 hWaitForInput h msecs = do
131 wantReadableHandle "hReady" h $ \ handle_ -> do
132 let ref = haBuffer handle_
135 if not (bufferEmpty buf)
139 r <- throwErrnoIfMinus1Retry "hReady"
140 (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs))
143 foreign import "inputReady"
144 inputReady :: CInt -> CInt -> IO CInt
146 -- ---------------------------------------------------------------------------
149 -- hGetChar reads the next character from a handle,
150 -- blocking until a character is available.
152 hGetChar :: Handle -> IO Char
154 wantReadableHandle "hGetChar" handle $ \handle_ -> do
156 let fd = haFD handle_
157 ref = haBuffer handle_
160 if not (bufferEmpty buf)
161 then hGetcBuffered fd ref buf
165 case haBufferMode handle_ of
167 new_buf <- fillReadBuffer fd True buf
168 hGetcBuffered fd ref new_buf
169 BlockBuffering _ -> do
170 new_buf <- fillReadBuffer fd False buf
171 hGetcBuffered fd ref new_buf
173 -- make use of the minimal buffer we already have
175 r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
176 (read_off (fromIntegral fd) raw 0 1)
180 else do (c,_) <- readCharFromBuffer raw 0
183 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
184 = do (c,r) <- readCharFromBuffer b r
185 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
186 | otherwise = buf{ bufRPtr=r }
187 writeIORef ref new_buf
190 -- ---------------------------------------------------------------------------
193 -- If EOF is reached before EOL is encountered, ignore the EOF and
194 -- return the partial line. Next attempt at calling hGetLine on the
195 -- handle will yield an EOF IO exception though.
197 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
199 hGetLine :: Handle -> IO String
201 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
202 case haBufferMode handle_ of
203 NoBuffering -> return Nothing
205 l <- hGetLineBuffered handle_
207 BlockBuffering _ -> do
208 l <- hGetLineBuffered handle_
211 Nothing -> hGetLineUnBuffered h
215 hGetLineBuffered handle_ = do
216 let ref = haBuffer handle_
218 hGetLineBufferedLoop handle_ ref buf []
221 hGetLineBufferedLoop handle_ ref
222 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
224 -- find the end-of-line character, if there is one
226 | r == w = return (False, w)
228 (c,r') <- readCharFromBuffer raw r
230 then return (True, r) -- NB. not r': don't include the '\n'
233 (eol, off) <- loop raw r
236 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
239 xs <- unpack raw r off
241 then do if w == off + 1
242 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
243 else writeIORef ref buf{ bufRPtr = off + 1 }
244 return (concat (reverse (xs:xss)))
246 maybe_buf <- maybeFillReadBuffer (haFD handle_) True
247 buf{ bufWPtr=0, bufRPtr=0 }
249 -- Nothing indicates we caught an EOF, and we may have a
250 -- partial line to return.
251 Nothing -> let str = concat (reverse (xs:xss)) in
256 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
259 maybeFillReadBuffer fd is_line buf
261 (do buf <- fillReadBuffer fd is_line buf
264 (\e -> do if isEOFError e
269 unpack :: RawBuffer -> Int -> Int -> IO [Char]
270 unpack buf r 0 = return ""
271 unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
274 | i <## r = (## s, acc ##)
276 case readCharArray## buf i s of
277 (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
280 hGetLineUnBuffered :: Handle -> IO String
281 hGetLineUnBuffered h = do
294 if isEOFError err then
304 -- -----------------------------------------------------------------------------
307 -- hGetContents returns the list of characters corresponding to the
308 -- unread portion of the channel or file managed by the handle, which
309 -- is made semi-closed.
311 -- hGetContents on a DuplexHandle only affects the read side: you can
312 -- carry on writing to it afterwards.
314 hGetContents :: Handle -> IO String
315 hGetContents handle =
316 withHandle "hGetContents" handle $ \handle_ ->
317 case haType handle_ of
318 ClosedHandle -> ioe_closedHandle
319 SemiClosedHandle -> ioe_closedHandle
320 AppendHandle -> ioe_notReadable
321 WriteHandle -> ioe_notReadable
322 _ -> do xs <- lazyRead handle
323 return (handle_{ haType=SemiClosedHandle}, xs )
325 -- Note that someone may close the semi-closed handle (or change its
326 -- buffering), so each time these lazy read functions are pulled on,
327 -- they have to check whether the handle has indeed been closed.
329 lazyRead :: Handle -> IO String
332 withHandle "lazyRead" handle $ \ handle_ -> do
333 case haType handle_ of
334 ClosedHandle -> return (handle_, "")
335 SemiClosedHandle -> lazyRead' handle handle_
337 (IOError (Just handle) IllegalOperation "lazyRead"
338 "illegal handle type" Nothing)
340 lazyRead' h handle_ = do
341 let ref = haBuffer handle_
344 -- even a NoBuffering handle can have a char in the buffer...
347 if not (bufferEmpty buf)
348 then lazyReadHaveBuffer h handle_ fd ref buf
351 case haBufferMode handle_ of
353 -- make use of the minimal buffer we already have
356 r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
357 (read_off (fromIntegral fd) raw 0 1)
360 then do handle_ <- hClose_help handle_
362 else do (c,_) <- readCharFromBuffer raw 0
364 return (handle_, c : rest)
366 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
367 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
369 -- we never want to block during the read, so we call fillReadBuffer with
370 -- is_line==True, which tells it to "just read what there is".
371 lazyReadBuffered h handle_ fd ref buf = do
373 (do buf <- fillReadBuffer fd True{-is_line-} buf
374 lazyReadHaveBuffer h handle_ fd ref buf
376 -- all I/O errors are discarded. Additionally, we close the handle.
377 (\e -> do handle_ <- hClose_help handle_
381 lazyReadHaveBuffer h handle_ fd ref buf = do
383 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
384 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
388 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
389 unpackAcc buf r 0 acc = return ""
390 unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
393 | i <## r = (## s, acc ##)
395 case readCharArray## buf i s of
396 (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
398 -- ---------------------------------------------------------------------------
401 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
402 -- managed by `hdl'. Characters may be buffered if buffering is
403 -- enabled for `hdl'.
405 hPutChar :: Handle -> Char -> IO ()
407 c `seq` do -- must evaluate c before grabbing the handle lock
408 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
409 let fd = haFD handle_
410 case haBufferMode handle_ of
411 LineBuffering -> hPutcBuffered handle_ True c
412 BlockBuffering _ -> hPutcBuffered handle_ False c
414 withObject (castCharToCChar c) $ \buf ->
415 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
416 (c_write (fromIntegral fd) buf 1)
420 hPutcBuffered handle_ is_line c = do
421 let ref = haBuffer handle_
424 w' <- writeCharIntoBuffer (bufBuf buf) w c
425 let new_buf = buf{ bufWPtr = w' }
426 if bufferFull new_buf || is_line && c == '\n'
428 flushed_buf <- flushWriteBuffer (haFD handle_) new_buf
429 writeIORef ref flushed_buf
431 writeIORef ref new_buf
434 hPutChars :: Handle -> [Char] -> IO ()
435 hPutChars handle [] = return ()
436 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
438 -- ---------------------------------------------------------------------------
441 -- `hPutStr hdl s' writes the string `s' to the file or
442 -- hannel managed by `hdl', buffering the output if needs be.
444 -- We go to some trouble to avoid keeping the handle locked while we're
445 -- evaluating the string argument to hPutStr, in case doing so triggers another
446 -- I/O operation on the same handle which would lead to deadlock. The classic
449 -- putStr (trace "hello" "world")
451 -- so the basic scheme is this:
453 -- * copy the string into a fresh buffer,
454 -- * "commit" the buffer to the handle.
456 -- Committing may involve simply copying the contents of the new
457 -- buffer into the handle's buffer, flushing one or both buffers, or
458 -- maybe just swapping the buffers over (if the handle's buffer was
459 -- empty). See commitBuffer below.
461 hPutStr :: Handle -> String -> IO ()
462 hPutStr handle str = do
463 buffer_mode <- wantWritableHandle "hPutStr" handle
464 (\ handle_ -> do getSpareBuffer handle_)
466 (NoBuffering, _) -> do
467 hPutChars handle str -- v. slow, but we don't care
468 (LineBuffering, buf) -> do
469 writeLines handle buf str
470 (BlockBuffering _, buf) -> do
471 writeBlocks handle buf str
474 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
475 getSpareBuffer Handle__{haBuffer=ref,
480 NoBuffering -> return (mode, error "no buffer!")
482 bufs <- readIORef spare_ref
485 BufferListCons b rest -> do
486 writeIORef spare_ref rest
487 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
489 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
490 return (mode, new_buf)
493 writeLines :: Handle -> Buffer -> String -> IO ()
494 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
496 shoveString :: Int -> [Char] -> IO ()
497 -- check n == len first, to ensure that shoveString is strict in n.
498 shoveString n cs | n == len = do
499 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
500 writeLines hdl new_buf cs
501 shoveString n [] = do
502 commitBuffer hdl raw len n False{-no flush-} True{-release-}
504 shoveString n (c:cs) = do
505 n' <- writeCharIntoBuffer raw n c
508 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
509 writeLines hdl new_buf cs
515 writeBlocks :: Handle -> Buffer -> String -> IO ()
516 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
518 shoveString :: Int -> [Char] -> IO ()
519 -- check n == len first, to ensure that shoveString is strict in n.
520 shoveString n cs | n == len = do
521 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
522 writeBlocks hdl new_buf cs
523 shoveString n [] = do
524 commitBuffer hdl raw len n False{-no flush-} True{-release-}
526 shoveString n (c:cs) = do
527 n' <- writeCharIntoBuffer raw n c
532 -- -----------------------------------------------------------------------------
533 -- commitBuffer handle buf sz count flush release
535 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
536 -- 'count' bytes of data) to handle (handle must be block or line buffered).
540 -- for block/line buffering,
541 -- 1. If there isn't room in the handle buffer, flush the handle
544 -- 2. If the handle buffer is empty,
546 -- then write buf directly to the device.
547 -- else swap the handle buffer with buf.
549 -- 3. If the handle buffer is non-empty, copy buf into the
550 -- handle buffer. Then, if flush != 0, flush
554 :: Handle -- handle to commit to
555 -> RawBuffer -> Int -- address and size (in bytes) of buffer
556 -> Int -- number of bytes of data in buffer
557 -> Bool -- True <=> flush the handle afterward
558 -> Bool -- release the buffer?
561 commitBuffer hdl raw sz@(I## _) count@(I## _) flush release = do
562 wantWritableHandle "commitAndReleaseBuffer" hdl $
563 commitBuffer' hdl raw sz count flush release
565 -- Explicitly lambda-lift this function to subvert GHC's full laziness
566 -- optimisations, which otherwise tends to float out subexpressions
567 -- past the \handle, which is really a pessimisation in this case because
568 -- that lambda is a one-shot lambda.
570 -- Don't forget to export the function, to stop it being inlined too.
572 -- This hack is a fairly big win for hPutStr performance.
574 commitBuffer' hdl raw sz@(I## _) count@(I## _) flush release
575 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
578 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
579 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
582 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
586 -- enough room in handle buffer?
587 if (not flush && (size - w > count))
588 -- The > is to be sure that we never exactly fill
589 -- up the buffer, which would require a flush. So
590 -- if copying the new data into the buffer would
591 -- make the buffer full, we just flush the existing
592 -- buffer and the new data immediately, rather than
593 -- copying before flushing.
595 -- not flushing, and there's enough room in the buffer:
596 -- just copy the data in and update bufWPtr.
597 then do memcpy_off old_raw w raw (fromIntegral count)
598 writeIORef ref old_buf{ bufWPtr = w + count }
599 return (newEmptyBuffer raw WriteBuffer sz)
601 -- else, we have to flush
602 else do flushed_buf <- flushWriteBuffer fd old_buf
605 Buffer{ bufBuf=raw, bufState=WriteBuffer,
606 bufRPtr=0, bufWPtr=count, bufSize=sz }
608 -- if: (a) we don't have to flush, and
609 -- (b) size(new buffer) == size(old buffer), and
610 -- (c) new buffer is not full,
611 -- we can just just swap them over...
612 if (not flush && sz == size && count /= sz)
614 writeIORef ref this_buf
617 -- otherwise, we have to flush the new data too,
618 -- and start with a fresh buffer
620 flushWriteBuffer fd this_buf
621 writeIORef ref flushed_buf
622 -- if the sizes were different, then allocate
623 -- a new buffer of the correct size.
625 then return (newEmptyBuffer raw WriteBuffer sz)
626 else allocateBuffer size WriteBuffer
628 -- release the buffer if necessary
629 if release && bufSize buf_ret == size
631 spare_bufs <- readIORef spare_buf_ref
632 writeIORef spare_buf_ref
633 (BufferListCons (bufBuf buf_ret) spare_bufs)
639 foreign import "memcpy_PrelIO_wrap" unsafe
640 memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
642 void *memcpy_PrelIO_wrap(char *dst, HsInt dst_off, const char *src, size_t sz) \
643 { return memcpy(dst+dst_off, src, sz); }
645 -- ---------------------------------------------------------------------------
648 -- Derived action `hPutStrLn hdl str' writes the string `str' to
649 -- the handle `hdl', adding a newline at the end.
651 hPutStrLn :: Handle -> String -> IO ()
652 hPutStrLn hndl str = do
656 -- ---------------------------------------------------------------------------
659 -- Computation `hPrint hdl t' writes the string representation of `t'
660 -- given by the `shows' function to the file or channel managed by `hdl'.
662 hPrint :: Show a => Handle -> a -> IO ()
663 hPrint hdl = hPutStrLn hdl . show