1 {-# OPTIONS -fno-implicit-prelude -#include "PrelIOUtils.h" #-}
5 -- -----------------------------------------------------------------------------
6 -- $Id: PrelIO.hs,v 1.6 2001/12/27 09:28:11 sof 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', -- hack, see below
23 hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
29 import PrelMarshalUtils
37 import PrelHandle -- much of the real stuff is in here
44 import PrelMaybe ( Maybe(..) )
47 import PrelException ( ioError, catch, throw )
50 -- -----------------------------------------------------------------------------
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
99 -- raises an exception instead of an error
100 readIO :: Read a => String -> IO a
101 readIO s = case (do { (x,t) <- reads s ;
104 #ifndef NEW_READS_REP
106 [] -> ioError (userError "Prelude.readIO: no parse")
107 _ -> ioError (userError "Prelude.readIO: ambiguous parse")
110 Nothing -> ioError (userError "Prelude.readIO: no parse")
113 -- ---------------------------------------------------------------------------
114 -- Simple input operations
116 -- Computation "hReady hdl" indicates whether at least
117 -- one item is available for input from handle "hdl".
119 -- If hWaitForInput finds anything in the Handle's buffer, it
120 -- immediately returns. If not, it tries to read from the underlying
121 -- OS handle. Notice that for buffered Handles connected to terminals
122 -- this means waiting until a complete line is available.
124 hReady :: Handle -> IO Bool
125 hReady h = hWaitForInput h 0
127 hWaitForInput :: Handle -> Int -> IO Bool
128 hWaitForInput h msecs = do
129 wantReadableHandle "hReady" h $ \ handle_ -> do
130 let ref = haBuffer handle_
133 if not (bufferEmpty buf)
137 r <- throwErrnoIfMinus1Retry "hReady"
138 (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
141 foreign import "inputReady" unsafe
142 inputReady :: CInt -> CInt -> Bool -> IO CInt
144 -- ---------------------------------------------------------------------------
147 -- hGetChar reads the next character from a handle,
148 -- blocking until a character is available.
150 hGetChar :: Handle -> IO Char
152 wantReadableHandle "hGetChar" handle $ \handle_ -> do
154 let fd = haFD handle_
155 ref = haBuffer handle_
158 if not (bufferEmpty buf)
159 then hGetcBuffered fd ref buf
163 case haBufferMode handle_ of
165 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
166 hGetcBuffered fd ref new_buf
167 BlockBuffering _ -> do
168 new_buf <- fillReadBuffer fd False (haIsStream handle_) buf
169 hGetcBuffered fd ref new_buf
171 -- make use of the minimal buffer we already have
173 r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
174 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
178 else do (c,_) <- readCharFromBuffer raw 0
181 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
182 = do (c,r) <- readCharFromBuffer b r
183 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
184 | otherwise = buf{ bufRPtr=r }
185 writeIORef ref new_buf
188 -- ---------------------------------------------------------------------------
191 -- If EOF is reached before EOL is encountered, ignore the EOF and
192 -- return the partial line. Next attempt at calling hGetLine on the
193 -- handle will yield an EOF IO exception though.
195 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
197 hGetLine :: Handle -> IO String
199 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
200 case haBufferMode handle_ of
201 NoBuffering -> return Nothing
203 l <- hGetLineBuffered handle_
205 BlockBuffering _ -> do
206 l <- hGetLineBuffered handle_
209 Nothing -> hGetLineUnBuffered h
213 hGetLineBuffered handle_ = do
214 let ref = haBuffer handle_
216 hGetLineBufferedLoop handle_ ref buf []
219 hGetLineBufferedLoop handle_ ref
220 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
222 -- find the end-of-line character, if there is one
224 | r == w = return (False, w)
226 (c,r') <- readCharFromBuffer raw r
228 then return (True, r) -- NB. not r': don't include the '\n'
231 (eol, off) <- loop raw r
234 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
237 xs <- unpack raw r off
239 then do if w == off + 1
240 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
241 else writeIORef ref buf{ bufRPtr = off + 1 }
242 return (concat (reverse (xs:xss)))
244 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
245 buf{ bufWPtr=0, bufRPtr=0 }
247 -- Nothing indicates we caught an EOF, and we may have a
248 -- partial line to return.
249 Nothing -> let str = concat (reverse (xs:xss)) in
254 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
257 maybeFillReadBuffer fd is_line is_stream buf
259 (do buf <- fillReadBuffer fd is_line is_stream buf
262 (\e -> do if isEOFError e
267 unpack :: RawBuffer -> Int -> Int -> IO [Char]
268 unpack buf r 0 = return ""
269 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
272 | i <# r = (# s, acc #)
274 case readCharArray# buf i s of
275 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
278 hGetLineUnBuffered :: Handle -> IO String
279 hGetLineUnBuffered h = do
292 if isEOFError err then
302 -- -----------------------------------------------------------------------------
305 -- hGetContents returns the list of characters corresponding to the
306 -- unread portion of the channel or file managed by the handle, which
307 -- is made semi-closed.
309 -- hGetContents on a DuplexHandle only affects the read side: you can
310 -- carry on writing to it afterwards.
312 hGetContents :: Handle -> IO String
313 hGetContents handle =
314 withHandle "hGetContents" handle $ \handle_ ->
315 case haType handle_ of
316 ClosedHandle -> ioe_closedHandle
317 SemiClosedHandle -> ioe_closedHandle
318 AppendHandle -> ioe_notReadable
319 WriteHandle -> ioe_notReadable
320 _ -> do xs <- lazyRead handle
321 return (handle_{ haType=SemiClosedHandle}, xs )
323 -- Note that someone may close the semi-closed handle (or change its
324 -- buffering), so each time these lazy read functions are pulled on,
325 -- they have to check whether the handle has indeed been closed.
327 lazyRead :: Handle -> IO String
330 withHandle "lazyRead" handle $ \ handle_ -> do
331 case haType handle_ of
332 ClosedHandle -> return (handle_, "")
333 SemiClosedHandle -> lazyRead' handle handle_
335 (IOError (Just handle) IllegalOperation "lazyRead"
336 "illegal handle type" Nothing)
338 lazyRead' h handle_ = do
339 let ref = haBuffer handle_
342 -- even a NoBuffering handle can have a char in the buffer...
345 if not (bufferEmpty buf)
346 then lazyReadHaveBuffer h handle_ fd ref buf
349 case haBufferMode handle_ of
351 -- make use of the minimal buffer we already have
353 r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
354 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
357 then do handle_ <- hClose_help handle_
359 else do (c,_) <- readCharFromBuffer raw 0
361 return (handle_, c : rest)
363 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
364 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
366 -- we never want to block during the read, so we call fillReadBuffer with
367 -- is_line==True, which tells it to "just read what there is".
368 lazyReadBuffered h handle_ fd ref buf = do
370 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
371 lazyReadHaveBuffer h handle_ fd ref buf
373 -- all I/O errors are discarded. Additionally, we close the handle.
374 (\e -> do handle_ <- hClose_help handle_
378 lazyReadHaveBuffer h handle_ fd ref buf = do
380 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
381 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
385 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
386 unpackAcc buf r 0 acc = return ""
387 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
390 | i <# r = (# s, acc #)
392 case readCharArray# buf i s of
393 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
395 -- ---------------------------------------------------------------------------
398 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
399 -- managed by `hdl'. Characters may be buffered if buffering is
400 -- enabled for `hdl'.
402 hPutChar :: Handle -> Char -> IO ()
404 c `seq` do -- must evaluate c before grabbing the handle lock
405 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
406 let fd = haFD handle_
407 case haBufferMode handle_ of
408 LineBuffering -> hPutcBuffered handle_ True c
409 BlockBuffering _ -> hPutcBuffered handle_ False c
411 withObject (castCharToCChar c) $ \buf ->
412 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
413 (write_off (fromIntegral fd) (haIsStream handle_) buf 0 1)
417 hPutcBuffered handle_ is_line c = do
418 let ref = haBuffer handle_
421 w' <- writeCharIntoBuffer (bufBuf buf) w c
422 let new_buf = buf{ bufWPtr = w' }
423 if bufferFull new_buf || is_line && c == '\n'
425 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
426 writeIORef ref flushed_buf
428 writeIORef ref new_buf
431 hPutChars :: Handle -> [Char] -> IO ()
432 hPutChars handle [] = return ()
433 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
435 -- ---------------------------------------------------------------------------
438 -- `hPutStr hdl s' writes the string `s' to the file or
439 -- hannel managed by `hdl', buffering the output if needs be.
441 -- We go to some trouble to avoid keeping the handle locked while we're
442 -- evaluating the string argument to hPutStr, in case doing so triggers another
443 -- I/O operation on the same handle which would lead to deadlock. The classic
446 -- putStr (trace "hello" "world")
448 -- so the basic scheme is this:
450 -- * copy the string into a fresh buffer,
451 -- * "commit" the buffer to the handle.
453 -- Committing may involve simply copying the contents of the new
454 -- buffer into the handle's buffer, flushing one or both buffers, or
455 -- maybe just swapping the buffers over (if the handle's buffer was
456 -- empty). See commitBuffer below.
458 hPutStr :: Handle -> String -> IO ()
459 hPutStr handle str = do
460 buffer_mode <- wantWritableHandle "hPutStr" handle
461 (\ handle_ -> do getSpareBuffer handle_)
463 (NoBuffering, _) -> do
464 hPutChars handle str -- v. slow, but we don't care
465 (LineBuffering, buf) -> do
466 writeLines handle buf str
467 (BlockBuffering _, buf) -> do
468 writeBlocks handle buf str
471 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
472 getSpareBuffer Handle__{haBuffer=ref,
477 NoBuffering -> return (mode, error "no buffer!")
479 bufs <- readIORef spare_ref
482 BufferListCons b rest -> do
483 writeIORef spare_ref rest
484 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
486 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
487 return (mode, new_buf)
490 writeLines :: Handle -> Buffer -> String -> IO ()
491 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
493 shoveString :: Int -> [Char] -> IO ()
494 -- check n == len first, to ensure that shoveString is strict in n.
495 shoveString n cs | n == len = do
496 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
497 writeLines hdl new_buf cs
498 shoveString n [] = do
499 commitBuffer hdl raw len n False{-no flush-} True{-release-}
501 shoveString n (c:cs) = do
502 n' <- writeCharIntoBuffer raw n c
505 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
506 writeLines hdl new_buf cs
512 writeBlocks :: Handle -> Buffer -> String -> IO ()
513 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
515 shoveString :: Int -> [Char] -> IO ()
516 -- check n == len first, to ensure that shoveString is strict in n.
517 shoveString n cs | n == len = do
518 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
519 writeBlocks hdl new_buf cs
520 shoveString n [] = do
521 commitBuffer hdl raw len n False{-no flush-} True{-release-}
523 shoveString n (c:cs) = do
524 n' <- writeCharIntoBuffer raw n c
529 -- -----------------------------------------------------------------------------
530 -- commitBuffer handle buf sz count flush release
532 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
533 -- 'count' bytes of data) to handle (handle must be block or line buffered).
537 -- for block/line buffering,
538 -- 1. If there isn't room in the handle buffer, flush the handle
541 -- 2. If the handle buffer is empty,
543 -- then write buf directly to the device.
544 -- else swap the handle buffer with buf.
546 -- 3. If the handle buffer is non-empty, copy buf into the
547 -- handle buffer. Then, if flush != 0, flush
551 :: Handle -- handle to commit to
552 -> RawBuffer -> Int -- address and size (in bytes) of buffer
553 -> Int -- number of bytes of data in buffer
554 -> Bool -- True <=> flush the handle afterward
555 -> Bool -- release the buffer?
558 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
559 wantWritableHandle "commitAndReleaseBuffer" hdl $
560 commitBuffer' hdl raw sz count flush release
562 -- Explicitly lambda-lift this function to subvert GHC's full laziness
563 -- optimisations, which otherwise tends to float out subexpressions
564 -- past the \handle, which is really a pessimisation in this case because
565 -- that lambda is a one-shot lambda.
567 -- Don't forget to export the function, to stop it being inlined too
568 -- (this appears to be better than NOINLINE, because the strictness
569 -- analyser still gets to worker-wrapper it).
571 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
573 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
574 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
577 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
578 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
581 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
585 -- enough room in handle buffer?
586 if (not flush && (size - w > count))
587 -- The > is to be sure that we never exactly fill
588 -- up the buffer, which would require a flush. So
589 -- if copying the new data into the buffer would
590 -- make the buffer full, we just flush the existing
591 -- buffer and the new data immediately, rather than
592 -- copying before flushing.
594 -- not flushing, and there's enough room in the buffer:
595 -- just copy the data in and update bufWPtr.
596 then do memcpy_off old_raw w raw (fromIntegral count)
597 writeIORef ref old_buf{ bufWPtr = w + count }
598 return (newEmptyBuffer raw WriteBuffer sz)
600 -- else, we have to flush
601 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
604 Buffer{ bufBuf=raw, bufState=WriteBuffer,
605 bufRPtr=0, bufWPtr=count, bufSize=sz }
607 -- if: (a) we don't have to flush, and
608 -- (b) size(new buffer) == size(old buffer), and
609 -- (c) new buffer is not full,
610 -- we can just just swap them over...
611 if (not flush && sz == size && count /= sz)
613 writeIORef ref this_buf
616 -- otherwise, we have to flush the new data too,
617 -- and start with a fresh buffer
619 flushWriteBuffer fd (haIsStream handle_) this_buf
620 writeIORef ref flushed_buf
621 -- if the sizes were different, then allocate
622 -- a new buffer of the correct size.
624 then return (newEmptyBuffer raw WriteBuffer sz)
625 else allocateBuffer size WriteBuffer
627 -- release the buffer if necessary
629 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
630 if release && buf_ret_sz == size
632 spare_bufs <- readIORef spare_buf_ref
633 writeIORef spare_buf_ref
634 (BufferListCons buf_ret_raw spare_bufs)
640 foreign import "prel_PrelIO_memcpy" unsafe
641 memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
643 -- ---------------------------------------------------------------------------
646 -- Derived action `hPutStrLn hdl str' writes the string `str' to
647 -- the handle `hdl', adding a newline at the end.
649 hPutStrLn :: Handle -> String -> IO ()
650 hPutStrLn hndl str = do
654 -- ---------------------------------------------------------------------------
657 -- Computation `hPrint hdl t' writes the string representation of `t'
658 -- given by the `shows' function to the file or channel managed by `hdl'.
660 hPrint :: Show a => Handle -> a -> IO ()
661 hPrint hdl = hPutStrLn hdl . show