1 {-# OPTIONS -fno-implicit-prelude #-}
5 -- -----------------------------------------------------------------------------
6 -- $Id: PrelIO.hsc,v 1.16 2001/09/18 08:32:11 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', -- hack, see below
23 hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
27 #include "PrelHandle_hsc.h"
32 import PrelMarshalUtils
40 import PrelHandle -- much of the real stuff is in here
47 import PrelMaybe ( Maybe(..) )
50 import PrelException ( ioError, catch, throw )
53 -- -----------------------------------------------------------------------------
56 putChar :: Char -> IO ()
57 putChar c = hPutChar stdout c
59 putStr :: String -> IO ()
60 putStr s = hPutStr stdout s
62 putStrLn :: String -> IO ()
63 putStrLn s = do putStr s
66 print :: Show a => a -> IO ()
67 print x = putStrLn (show x)
70 getChar = hGetChar stdin
73 getLine = hGetLine stdin
75 getContents :: IO String
76 getContents = hGetContents stdin
78 interact :: (String -> String) -> IO ()
79 interact f = do s <- getContents
82 readFile :: FilePath -> IO String
83 readFile name = openFile name ReadMode >>= hGetContents
85 writeFile :: FilePath -> String -> IO ()
86 writeFile name str = do
87 hdl <- openFile name WriteMode
91 appendFile :: FilePath -> String -> IO ()
92 appendFile name str = do
93 hdl <- openFile name AppendMode
97 readLn :: Read a => IO a
98 readLn = do l <- getLine
102 -- raises an exception instead of an error
103 readIO :: Read a => String -> IO a
104 readIO s = case (do { (x,t) <- reads s ;
107 #ifndef NEW_READS_REP
109 [] -> ioError (userError "Prelude.readIO: no parse")
110 _ -> ioError (userError "Prelude.readIO: ambiguous parse")
113 Nothing -> ioError (userError "Prelude.readIO: no parse")
116 -- ---------------------------------------------------------------------------
117 -- Simple input operations
119 -- Computation "hReady hdl" indicates whether at least
120 -- one item is available for input from handle "hdl".
122 -- If hWaitForInput finds anything in the Handle's buffer, it
123 -- immediately returns. If not, it tries to read from the underlying
124 -- OS handle. Notice that for buffered Handles connected to terminals
125 -- this means waiting until a complete line is available.
127 hReady :: Handle -> IO Bool
128 hReady h = hWaitForInput h 0
130 hWaitForInput :: Handle -> Int -> IO Bool
131 hWaitForInput h msecs = do
132 wantReadableHandle "hReady" h $ \ handle_ -> do
133 let ref = haBuffer handle_
136 if not (bufferEmpty buf)
140 r <- throwErrnoIfMinus1Retry "hReady"
141 (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs))
144 foreign import "inputReady"
145 inputReady :: CInt -> CInt -> IO CInt
147 -- ---------------------------------------------------------------------------
150 -- hGetChar reads the next character from a handle,
151 -- blocking until a character is available.
153 hGetChar :: Handle -> IO Char
155 wantReadableHandle "hGetChar" handle $ \handle_ -> do
157 let fd = haFD handle_
158 ref = haBuffer handle_
161 if not (bufferEmpty buf)
162 then hGetcBuffered fd ref buf
166 case haBufferMode handle_ of
168 new_buf <- fillReadBuffer fd True buf
169 hGetcBuffered fd ref new_buf
170 BlockBuffering _ -> do
171 new_buf <- fillReadBuffer fd False buf
172 hGetcBuffered fd ref new_buf
174 -- make use of the minimal buffer we already have
176 r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
177 (read_off (fromIntegral fd) raw 0 1)
181 else do (c,_) <- readCharFromBuffer raw 0
184 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
185 = do (c,r) <- readCharFromBuffer b r
186 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
187 | otherwise = buf{ bufRPtr=r }
188 writeIORef ref new_buf
191 -- ---------------------------------------------------------------------------
194 -- If EOF is reached before EOL is encountered, ignore the EOF and
195 -- return the partial line. Next attempt at calling hGetLine on the
196 -- handle will yield an EOF IO exception though.
198 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
200 hGetLine :: Handle -> IO String
202 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
203 case haBufferMode handle_ of
204 NoBuffering -> return Nothing
206 l <- hGetLineBuffered handle_
208 BlockBuffering _ -> do
209 l <- hGetLineBuffered handle_
212 Nothing -> hGetLineUnBuffered h
216 hGetLineBuffered handle_ = do
217 let ref = haBuffer handle_
219 hGetLineBufferedLoop handle_ ref buf []
222 hGetLineBufferedLoop handle_ ref
223 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
225 -- find the end-of-line character, if there is one
227 | r == w = return (False, w)
229 (c,r') <- readCharFromBuffer raw r
231 then return (True, r) -- NB. not r': don't include the '\n'
234 (eol, off) <- loop raw r
237 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
240 xs <- unpack raw r off
242 then do if w == off + 1
243 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
244 else writeIORef ref buf{ bufRPtr = off + 1 }
245 return (concat (reverse (xs:xss)))
247 maybe_buf <- maybeFillReadBuffer (haFD handle_) True
248 buf{ bufWPtr=0, bufRPtr=0 }
250 -- Nothing indicates we caught an EOF, and we may have a
251 -- partial line to return.
252 Nothing -> let str = concat (reverse (xs:xss)) in
257 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
260 maybeFillReadBuffer fd is_line buf
262 (do buf <- fillReadBuffer fd is_line buf
265 (\e -> do if isEOFError e
270 unpack :: RawBuffer -> Int -> Int -> IO [Char]
271 unpack buf r 0 = return ""
272 unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
275 | i <## r = (## s, acc ##)
277 case readCharArray## buf i s of
278 (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
281 hGetLineUnBuffered :: Handle -> IO String
282 hGetLineUnBuffered h = do
295 if isEOFError err then
305 -- -----------------------------------------------------------------------------
308 -- hGetContents returns the list of characters corresponding to the
309 -- unread portion of the channel or file managed by the handle, which
310 -- is made semi-closed.
312 -- hGetContents on a DuplexHandle only affects the read side: you can
313 -- carry on writing to it afterwards.
315 hGetContents :: Handle -> IO String
316 hGetContents handle =
317 withHandle "hGetContents" handle $ \handle_ ->
318 case haType handle_ of
319 ClosedHandle -> ioe_closedHandle
320 SemiClosedHandle -> ioe_closedHandle
321 AppendHandle -> ioe_notReadable
322 WriteHandle -> ioe_notReadable
323 _ -> do xs <- lazyRead handle
324 return (handle_{ haType=SemiClosedHandle}, xs )
326 -- Note that someone may close the semi-closed handle (or change its
327 -- buffering), so each time these lazy read functions are pulled on,
328 -- they have to check whether the handle has indeed been closed.
330 lazyRead :: Handle -> IO String
333 withHandle "lazyRead" handle $ \ handle_ -> do
334 case haType handle_ of
335 ClosedHandle -> return (handle_, "")
336 SemiClosedHandle -> lazyRead' handle handle_
338 (IOError (Just handle) IllegalOperation "lazyRead"
339 "illegal handle type" Nothing)
341 lazyRead' h handle_ = do
342 let ref = haBuffer handle_
345 -- even a NoBuffering handle can have a char in the buffer...
348 if not (bufferEmpty buf)
349 then lazyReadHaveBuffer h handle_ fd ref buf
352 case haBufferMode handle_ of
354 -- make use of the minimal buffer we already have
357 r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
358 (read_off (fromIntegral fd) raw 0 1)
361 then do handle_ <- hClose_help handle_
363 else do (c,_) <- readCharFromBuffer raw 0
365 return (handle_, c : rest)
367 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
368 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
370 -- we never want to block during the read, so we call fillReadBuffer with
371 -- is_line==True, which tells it to "just read what there is".
372 lazyReadBuffered h handle_ fd ref buf = do
374 (do buf <- fillReadBuffer fd True{-is_line-} buf
375 lazyReadHaveBuffer h handle_ fd ref buf
377 -- all I/O errors are discarded. Additionally, we close the handle.
378 (\e -> do handle_ <- hClose_help handle_
382 lazyReadHaveBuffer h handle_ fd ref buf = do
384 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
385 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
389 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
390 unpackAcc buf r 0 acc = return ""
391 unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
394 | i <## r = (## s, acc ##)
396 case readCharArray## buf i s of
397 (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
399 -- ---------------------------------------------------------------------------
402 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
403 -- managed by `hdl'. Characters may be buffered if buffering is
404 -- enabled for `hdl'.
406 hPutChar :: Handle -> Char -> IO ()
408 c `seq` do -- must evaluate c before grabbing the handle lock
409 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
410 let fd = haFD handle_
411 case haBufferMode handle_ of
412 LineBuffering -> hPutcBuffered handle_ True c
413 BlockBuffering _ -> hPutcBuffered handle_ False c
415 withObject (castCharToCChar c) $ \buf ->
416 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
417 (c_write (fromIntegral fd) buf 1)
421 hPutcBuffered handle_ is_line c = do
422 let ref = haBuffer handle_
425 w' <- writeCharIntoBuffer (bufBuf buf) w c
426 let new_buf = buf{ bufWPtr = w' }
427 if bufferFull new_buf || is_line && c == '\n'
429 flushed_buf <- flushWriteBuffer (haFD handle_) new_buf
430 writeIORef ref flushed_buf
432 writeIORef ref new_buf
435 hPutChars :: Handle -> [Char] -> IO ()
436 hPutChars handle [] = return ()
437 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
439 -- ---------------------------------------------------------------------------
442 -- `hPutStr hdl s' writes the string `s' to the file or
443 -- hannel managed by `hdl', buffering the output if needs be.
445 -- We go to some trouble to avoid keeping the handle locked while we're
446 -- evaluating the string argument to hPutStr, in case doing so triggers another
447 -- I/O operation on the same handle which would lead to deadlock. The classic
450 -- putStr (trace "hello" "world")
452 -- so the basic scheme is this:
454 -- * copy the string into a fresh buffer,
455 -- * "commit" the buffer to the handle.
457 -- Committing may involve simply copying the contents of the new
458 -- buffer into the handle's buffer, flushing one or both buffers, or
459 -- maybe just swapping the buffers over (if the handle's buffer was
460 -- empty). See commitBuffer below.
462 hPutStr :: Handle -> String -> IO ()
463 hPutStr handle str = do
464 buffer_mode <- wantWritableHandle "hPutStr" handle
465 (\ handle_ -> do getSpareBuffer handle_)
467 (NoBuffering, _) -> do
468 hPutChars handle str -- v. slow, but we don't care
469 (LineBuffering, buf) -> do
470 writeLines handle buf str
471 (BlockBuffering _, buf) -> do
472 writeBlocks handle buf str
475 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
476 getSpareBuffer Handle__{haBuffer=ref,
481 NoBuffering -> return (mode, error "no buffer!")
483 bufs <- readIORef spare_ref
486 BufferListCons b rest -> do
487 writeIORef spare_ref rest
488 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
490 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
491 return (mode, new_buf)
494 writeLines :: Handle -> Buffer -> String -> IO ()
495 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
497 shoveString :: Int -> [Char] -> IO ()
498 -- check n == len first, to ensure that shoveString is strict in n.
499 shoveString n cs | n == len = do
500 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
501 writeLines hdl new_buf cs
502 shoveString n [] = do
503 commitBuffer hdl raw len n False{-no flush-} True{-release-}
505 shoveString n (c:cs) = do
506 n' <- writeCharIntoBuffer raw n c
509 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
510 writeLines hdl new_buf cs
516 writeBlocks :: Handle -> Buffer -> String -> IO ()
517 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
519 shoveString :: Int -> [Char] -> IO ()
520 -- check n == len first, to ensure that shoveString is strict in n.
521 shoveString n cs | n == len = do
522 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
523 writeBlocks hdl new_buf cs
524 shoveString n [] = do
525 commitBuffer hdl raw len n False{-no flush-} True{-release-}
527 shoveString n (c:cs) = do
528 n' <- writeCharIntoBuffer raw n c
533 -- -----------------------------------------------------------------------------
534 -- commitBuffer handle buf sz count flush release
536 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
537 -- 'count' bytes of data) to handle (handle must be block or line buffered).
541 -- for block/line buffering,
542 -- 1. If there isn't room in the handle buffer, flush the handle
545 -- 2. If the handle buffer is empty,
547 -- then write buf directly to the device.
548 -- else swap the handle buffer with buf.
550 -- 3. If the handle buffer is non-empty, copy buf into the
551 -- handle buffer. Then, if flush != 0, flush
555 :: Handle -- handle to commit to
556 -> RawBuffer -> Int -- address and size (in bytes) of buffer
557 -> Int -- number of bytes of data in buffer
558 -> Bool -- True <=> flush the handle afterward
559 -> Bool -- release the buffer?
562 commitBuffer hdl raw sz@(I## _) count@(I## _) flush release = do
563 wantWritableHandle "commitAndReleaseBuffer" hdl $
564 commitBuffer' hdl raw sz count flush release
566 -- Explicitly lambda-lift this function to subvert GHC's full laziness
567 -- optimisations, which otherwise tends to float out subexpressions
568 -- past the \handle, which is really a pessimisation in this case because
569 -- that lambda is a one-shot lambda.
571 -- Don't forget to export the function, to stop it being inlined too
572 -- (this appears to be better than NOINLINE, because the strictness
573 -- analyser still gets to worker-wrapper it).
575 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
577 commitBuffer' hdl raw sz@(I## _) count@(I## _) flush release
578 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
581 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
582 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
585 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
589 -- enough room in handle buffer?
590 if (not flush && (size - w > count))
591 -- The > is to be sure that we never exactly fill
592 -- up the buffer, which would require a flush. So
593 -- if copying the new data into the buffer would
594 -- make the buffer full, we just flush the existing
595 -- buffer and the new data immediately, rather than
596 -- copying before flushing.
598 -- not flushing, and there's enough room in the buffer:
599 -- just copy the data in and update bufWPtr.
600 then do memcpy_off old_raw w raw (fromIntegral count)
601 writeIORef ref old_buf{ bufWPtr = w + count }
602 return (newEmptyBuffer raw WriteBuffer sz)
604 -- else, we have to flush
605 else do flushed_buf <- flushWriteBuffer fd old_buf
608 Buffer{ bufBuf=raw, bufState=WriteBuffer,
609 bufRPtr=0, bufWPtr=count, bufSize=sz }
611 -- if: (a) we don't have to flush, and
612 -- (b) size(new buffer) == size(old buffer), and
613 -- (c) new buffer is not full,
614 -- we can just just swap them over...
615 if (not flush && sz == size && count /= sz)
617 writeIORef ref this_buf
620 -- otherwise, we have to flush the new data too,
621 -- and start with a fresh buffer
623 flushWriteBuffer fd this_buf
624 writeIORef ref flushed_buf
625 -- if the sizes were different, then allocate
626 -- a new buffer of the correct size.
628 then return (newEmptyBuffer raw WriteBuffer sz)
629 else allocateBuffer size WriteBuffer
631 -- release the buffer if necessary
633 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
634 if release && buf_ret_sz == size
636 spare_bufs <- readIORef spare_buf_ref
637 writeIORef spare_buf_ref
638 (BufferListCons buf_ret_raw spare_bufs)
644 foreign import "memcpy_PrelIO_wrap" unsafe
645 memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
647 void *memcpy_PrelIO_wrap(char *dst, HsInt dst_off, const char *src, size_t sz) \
648 { return memcpy(dst+dst_off, src, sz); }
650 -- ---------------------------------------------------------------------------
653 -- Derived action `hPutStrLn hdl str' writes the string `str' to
654 -- the handle `hdl', adding a newline at the end.
656 hPutStrLn :: Handle -> String -> IO ()
657 hPutStrLn hndl str = do
661 -- ---------------------------------------------------------------------------
664 -- Computation `hPrint hdl t' writes the string representation of `t'
665 -- given by the `shows' function to the file or channel managed by `hdl'.
667 hPrint :: Show a => Handle -> a -> IO ()
668 hPrint hdl = hPutStrLn hdl . show