1 {-# OPTIONS -fno-implicit-prelude #-}
5 -- -----------------------------------------------------------------------------
6 -- $Id: PrelIO.hsc,v 1.13 2001/09/17 14:58:09 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,
25 #include "PrelHandle_hsc.h"
30 import PrelMarshalUtils
38 import PrelHandle -- much of the real stuff is in here
45 import PrelMaybe ( Maybe(..) )
48 import PrelException ( ioError, catch, throw )
51 -- -----------------------------------------------------------------------------
54 putChar :: Char -> IO ()
55 putChar c = hPutChar stdout c
57 putStr :: String -> IO ()
58 putStr s = hPutStr stdout s
60 putStrLn :: String -> IO ()
61 putStrLn s = do putStr s
64 print :: Show a => a -> IO ()
65 print x = putStrLn (show x)
68 getChar = hGetChar stdin
71 getLine = hGetLine stdin
73 getContents :: IO String
74 getContents = hGetContents stdin
76 interact :: (String -> String) -> IO ()
77 interact f = do s <- getContents
80 readFile :: FilePath -> IO String
81 readFile name = openFile name ReadMode >>= hGetContents
83 writeFile :: FilePath -> String -> IO ()
84 writeFile name str = do
85 hdl <- openFile name WriteMode
89 appendFile :: FilePath -> String -> IO ()
90 appendFile name str = do
91 hdl <- openFile name AppendMode
95 readLn :: Read a => IO a
96 readLn = do l <- getLine
100 -- raises an exception instead of an error
101 readIO :: Read a => String -> IO a
102 readIO s = case (do { (x,t) <- reads s ;
105 #ifndef NEW_READS_REP
107 [] -> ioError (userError "Prelude.readIO: no parse")
108 _ -> ioError (userError "Prelude.readIO: ambiguous parse")
111 Nothing -> ioError (userError "Prelude.readIO: no parse")
114 -- ---------------------------------------------------------------------------
115 -- Simple input operations
117 -- Computation "hReady hdl" indicates whether at least
118 -- one item is available for input from handle "hdl".
120 -- If hWaitForInput finds anything in the Handle's buffer, it
121 -- immediately returns. If not, it tries to read from the underlying
122 -- OS handle. Notice that for buffered Handles connected to terminals
123 -- this means waiting until a complete line is available.
125 hReady :: Handle -> IO Bool
126 hReady h = hWaitForInput h 0
128 hWaitForInput :: Handle -> Int -> IO Bool
129 hWaitForInput h msecs = do
130 wantReadableHandle "hReady" h $ \ handle_ -> do
131 let ref = haBuffer handle_
134 if not (bufferEmpty buf)
138 r <- throwErrnoIfMinus1Retry "hReady"
139 (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs))
142 foreign import "inputReady"
143 inputReady :: CInt -> CInt -> IO CInt
145 -- ---------------------------------------------------------------------------
148 -- hGetChar reads the next character from a handle,
149 -- blocking until a character is available.
151 hGetChar :: Handle -> IO Char
153 wantReadableHandle "hGetChar" handle $ \handle_ -> do
155 let fd = haFD handle_
156 ref = haBuffer handle_
159 if not (bufferEmpty buf)
160 then hGetcBuffered fd ref buf
164 case haBufferMode handle_ of
166 new_buf <- fillReadBuffer fd True buf
167 hGetcBuffered fd ref new_buf
168 BlockBuffering _ -> do
169 new_buf <- fillReadBuffer fd False buf
170 hGetcBuffered fd ref new_buf
172 -- make use of the minimal buffer we already have
174 r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
175 (read_off (fromIntegral fd) raw 0 1)
179 else do (c,_) <- readCharFromBuffer raw 0
182 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
183 = do (c,r) <- readCharFromBuffer b r
184 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
185 | otherwise = buf{ bufRPtr=r }
186 writeIORef ref new_buf
189 -- ---------------------------------------------------------------------------
192 -- If EOF is reached before EOL is encountered, ignore the EOF and
193 -- return the partial line. Next attempt at calling hGetLine on the
194 -- handle will yield an EOF IO exception though.
196 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
198 hGetLine :: Handle -> IO String
200 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
201 case haBufferMode handle_ of
202 NoBuffering -> return Nothing
204 l <- hGetLineBuffered handle_
206 BlockBuffering _ -> do
207 l <- hGetLineBuffered handle_
210 Nothing -> hGetLineUnBuffered h
214 hGetLineBuffered handle_ = do
215 let ref = haBuffer handle_
217 hGetLineBufferedLoop handle_ ref buf []
220 hGetLineBufferedLoop handle_ ref
221 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
223 -- find the end-of-line character, if there is one
225 | r == w = return (False, w)
227 (c,r') <- readCharFromBuffer raw r
229 then return (True, r) -- NB. not r': don't include the '\n'
232 (eol, off) <- loop raw r
235 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
238 xs <- unpack raw r off
240 then do if w == off + 1
241 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
242 else writeIORef ref buf{ bufRPtr = off + 1 }
243 return (concat (reverse (xs:xss)))
245 maybe_buf <- maybeFillReadBuffer (haFD handle_) True
246 buf{ bufWPtr=0, bufRPtr=0 }
248 -- Nothing indicates we caught an EOF, and we may have a
249 -- partial line to return.
250 Nothing -> let str = concat (reverse (xs:xss)) in
255 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
258 maybeFillReadBuffer fd is_line buf
260 (do buf <- fillReadBuffer fd is_line buf
263 (\e -> do if isEOFError e
268 unpack :: RawBuffer -> Int -> Int -> IO [Char]
269 unpack buf r 0 = return ""
270 unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
273 | i <## r = (## s, acc ##)
275 case readCharArray## buf i s of
276 (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
279 hGetLineUnBuffered :: Handle -> IO String
280 hGetLineUnBuffered h = do
293 if isEOFError err then
303 -- -----------------------------------------------------------------------------
306 -- hGetContents returns the list of characters corresponding to the
307 -- unread portion of the channel or file managed by the handle, which
308 -- is made semi-closed.
310 -- hGetContents on a DuplexHandle only affects the read side: you can
311 -- carry on writing to it afterwards.
313 hGetContents :: Handle -> IO String
314 hGetContents handle =
315 withHandle "hGetContents" handle $ \handle_ ->
316 case haType handle_ of
317 ClosedHandle -> ioe_closedHandle
318 SemiClosedHandle -> ioe_closedHandle
319 AppendHandle -> ioe_notReadable
320 WriteHandle -> ioe_notReadable
321 _ -> do xs <- lazyRead handle
322 return (handle_{ haType=SemiClosedHandle}, xs )
324 -- Note that someone may close the semi-closed handle (or change its
325 -- buffering), so each time these lazy read functions are pulled on,
326 -- they have to check whether the handle has indeed been closed.
328 lazyRead :: Handle -> IO String
331 withHandle "lazyRead" handle $ \ handle_ -> do
332 case haType handle_ of
333 ClosedHandle -> return (handle_, "")
334 SemiClosedHandle -> lazyRead' handle handle_
336 (IOError (Just handle) IllegalOperation "lazyRead"
337 "illegal handle type" Nothing)
339 lazyRead' h handle_ = do
340 let ref = haBuffer handle_
343 -- even a NoBuffering handle can have a char in the buffer...
346 if not (bufferEmpty buf)
347 then lazyReadHaveBuffer h handle_ fd ref buf
350 case haBufferMode handle_ of
352 -- make use of the minimal buffer we already have
355 r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
356 (read_off (fromIntegral fd) raw 0 1)
359 then do handle_ <- hClose_help handle_
361 else do (c,_) <- readCharFromBuffer raw 0
363 return (handle_, c : rest)
365 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
366 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
368 -- we never want to block during the read, so we call fillReadBuffer with
369 -- is_line==True, which tells it to "just read what there is".
370 lazyReadBuffered h handle_ fd ref buf = do
372 (do buf <- fillReadBuffer fd True{-is_line-} buf
373 lazyReadHaveBuffer h handle_ fd ref buf
375 -- all I/O errors are discarded. Additionally, we close the handle.
376 (\e -> do handle_ <- hClose_help handle_
380 lazyReadHaveBuffer h handle_ fd ref buf = do
382 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
383 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
387 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
388 unpackAcc buf r 0 acc = return ""
389 unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
392 | i <## r = (## s, acc ##)
394 case readCharArray## buf i s of
395 (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
397 -- ---------------------------------------------------------------------------
400 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
401 -- managed by `hdl'. Characters may be buffered if buffering is
402 -- enabled for `hdl'.
404 hPutChar :: Handle -> Char -> IO ()
406 c `seq` do -- must evaluate c before grabbing the handle lock
407 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
408 let fd = haFD handle_
409 case haBufferMode handle_ of
410 LineBuffering -> hPutcBuffered handle_ True c
411 BlockBuffering _ -> hPutcBuffered handle_ False c
413 withObject (castCharToCChar c) $ \buf ->
414 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
415 (c_write (fromIntegral fd) buf 1)
419 hPutcBuffered handle_ is_line c = do
420 let ref = haBuffer handle_
423 w' <- writeCharIntoBuffer (bufBuf buf) w c
424 let new_buf = buf{ bufWPtr = w' }
425 if bufferFull new_buf || is_line && c == '\n'
427 flushed_buf <- flushWriteBuffer (haFD handle_) new_buf
428 writeIORef ref flushed_buf
430 writeIORef ref new_buf
433 hPutChars :: Handle -> [Char] -> IO ()
434 hPutChars handle [] = return ()
435 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
437 -- ---------------------------------------------------------------------------
440 -- `hPutStr hdl s' writes the string `s' to the file or
441 -- hannel managed by `hdl', buffering the output if needs be.
443 -- We go to some trouble to avoid keeping the handle locked while we're
444 -- evaluating the string argument to hPutStr, in case doing so triggers another
445 -- I/O operation on the same handle which would lead to deadlock. The classic
448 -- putStr (trace "hello" "world")
450 -- so the basic scheme is this:
452 -- * copy the string into a fresh buffer,
453 -- * "commit" the buffer to the handle.
455 -- Committing may involve simply copying the contents of the new
456 -- buffer into the handle's buffer, flushing one or both buffers, or
457 -- maybe just swapping the buffers over (if the handle's buffer was
458 -- empty). See commitBuffer below.
460 hPutStr :: Handle -> String -> IO ()
461 hPutStr handle str = do
462 buffer_mode <- wantWritableHandle "hPutStr" handle
463 (\ handle_ -> do getSpareBuffer handle_)
465 (NoBuffering, _) -> do
466 hPutChars handle str -- v. slow, but we don't care
467 (LineBuffering, buf) -> do
468 writeLines handle buf str
469 (BlockBuffering _, buf) -> do
470 writeBlocks handle buf str
473 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
474 getSpareBuffer Handle__{haBuffer=ref,
479 NoBuffering -> return (mode, error "no buffer!")
481 bufs <- readIORef spare_ref
484 BufferListCons b rest -> do
485 writeIORef spare_ref rest
486 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
488 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
489 return (mode, new_buf)
492 writeLines :: Handle -> Buffer -> String -> IO ()
493 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
495 shoveString :: Int -> [Char] -> IO ()
496 -- check n == len first, to ensure that shoveString is strict in n.
497 shoveString n cs | n == len = do
498 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
499 writeLines hdl new_buf cs
500 shoveString n [] = do
501 commitBuffer hdl raw len n False{-no flush-} True{-release-}
503 shoveString n (c:cs) = do
504 n' <- writeCharIntoBuffer raw n c
507 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
508 writeLines hdl new_buf cs
514 writeBlocks :: Handle -> Buffer -> String -> IO ()
515 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
517 shoveString :: Int -> [Char] -> IO ()
518 -- check n == len first, to ensure that shoveString is strict in n.
519 shoveString n cs | n == len = do
520 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
521 writeBlocks hdl new_buf cs
522 shoveString n [] = do
523 commitBuffer hdl raw len n False{-no flush-} True{-release-}
525 shoveString n (c:cs) = do
526 n' <- writeCharIntoBuffer raw n c
531 -- -----------------------------------------------------------------------------
532 -- commitBuffer handle buf sz count flush release
534 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
535 -- 'count' bytes of data) to handle (handle must be block or line buffered).
539 -- for block/line buffering,
540 -- 1. If there isn't room in the handle buffer, flush the handle
543 -- 2. If the handle buffer is empty,
545 -- then write buf directly to the device.
546 -- else swap the handle buffer with buf.
548 -- 3. If the handle buffer is non-empty, copy buf into the
549 -- handle buffer. Then, if flush != 0, flush
553 :: Handle -- handle to commit to
554 -> RawBuffer -> Int -- address and size (in bytes) of buffer
555 -> Int -- number of bytes of data in buffer
556 -> Bool -- flush the handle afterward?
557 -> Bool -- release the buffer?
560 commitBuffer hdl raw sz count flush release = do
561 wantWritableHandle "commitAndReleaseBuffer" hdl $
562 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } -> do
565 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
566 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
569 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
573 -- enough room in handle buffer?
574 if (not flush && (size - w > count))
575 -- The > is to be sure that we never exactly fill
576 -- up the buffer, which would require a flush. So
577 -- if copying the new data into the buffer would
578 -- make the buffer full, we just flush the existing
579 -- buffer and the new data immediately, rather than
580 -- copying before flushing.
582 -- not flushing, and there's enough room in the buffer:
583 -- just copy the data in and update bufWPtr.
584 then do memcpy_off old_raw w raw (fromIntegral count)
585 writeIORef ref old_buf{ bufWPtr = w + count }
586 return (newEmptyBuffer raw WriteBuffer sz)
588 -- else, we have to flush
589 else do flushed_buf <- flushWriteBuffer fd old_buf
592 Buffer{ bufBuf=raw, bufState=WriteBuffer,
593 bufRPtr=0, bufWPtr=count, bufSize=sz }
595 -- if: (a) we don't have to flush, and
596 -- (b) size(new buffer) == size(old buffer), and
597 -- (c) new buffer is not full,
598 -- we can just just swap them over...
599 if (not flush && sz == size && count /= sz)
601 writeIORef ref this_buf
604 -- otherwise, we have to flush the new data too,
605 -- and start with a fresh buffer
607 flushWriteBuffer fd this_buf
608 writeIORef ref flushed_buf
609 -- if the sizes were different, then allocate
610 -- a new buffer of the correct size.
612 then return (newEmptyBuffer raw WriteBuffer sz)
613 else allocateBuffer size WriteBuffer
615 -- release the buffer if necessary
616 if release && bufSize buf_ret == size
618 spare_bufs <- readIORef spare_buf_ref
619 writeIORef spare_buf_ref
620 (BufferListCons (bufBuf buf_ret) spare_bufs)
626 foreign import "memcpy_PrelIO_wrap" unsafe
627 memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
629 void *memcpy_PrelIO_wrap(char *dst, HsInt dst_off, const char *src, size_t sz) \
630 { return memcpy(dst+dst_off, src, sz); }
632 -- ---------------------------------------------------------------------------
635 -- Derived action `hPutStrLn hdl str' writes the string `str' to
636 -- the handle `hdl', adding a newline at the end.
638 hPutStrLn :: Handle -> String -> IO ()
639 hPutStrLn hndl str = do
643 -- ---------------------------------------------------------------------------
646 -- Computation `hPrint hdl t' writes the string representation of `t'
647 -- given by the `shows' function to the file or channel managed by `hdl'.
649 hPrint :: Show a => Handle -> a -> IO ()
650 hPrint hdl = hPutStrLn hdl . show