1 {-# OPTIONS -fno-implicit-prelude #-}
5 -- -----------------------------------------------------------------------------
6 -- $Id: PrelIO.hsc,v 1.10 2001/08/17 11:08:01 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
20 #include "PrelHandle_hsc.h"
25 import PrelMarshalAlloc
26 import PrelMarshalUtils
34 import PrelHandle -- much of the real stuff is in here
41 import PrelMaybe ( Maybe(..) )
44 import PrelException ( ioError, catch, throw )
47 -- -----------------------------------------------------------------------------
50 putChar :: Char -> IO ()
51 putChar c = hPutChar stdout c
53 putStr :: String -> IO ()
54 putStr s = hPutStr stdout s
56 putStrLn :: String -> IO ()
57 putStrLn s = do putStr s
60 print :: Show a => a -> IO ()
61 print x = putStrLn (show x)
64 getChar = hGetChar stdin
67 getLine = hGetLine stdin
69 getContents :: IO String
70 getContents = hGetContents stdin
72 interact :: (String -> String) -> IO ()
73 interact f = do s <- getContents
76 readFile :: FilePath -> IO String
77 readFile name = openFile name ReadMode >>= hGetContents
79 writeFile :: FilePath -> String -> IO ()
80 writeFile name str = do
81 hdl <- openFile name WriteMode
85 appendFile :: FilePath -> String -> IO ()
86 appendFile name str = do
87 hdl <- openFile name AppendMode
91 readLn :: Read a => IO a
92 readLn = do l <- getLine
96 -- raises an exception instead of an error
97 readIO :: Read a => String -> IO a
98 readIO s = case (do { (x,t) <- reads s ;
101 #ifndef NEW_READS_REP
103 [] -> ioError (userError "Prelude.readIO: no parse")
104 _ -> ioError (userError "Prelude.readIO: ambiguous parse")
107 Nothing -> ioError (userError "Prelude.readIO: no parse")
110 -- ---------------------------------------------------------------------------
111 -- Simple input operations
113 -- Computation "hReady hdl" indicates whether at least
114 -- one item is available for input from handle "hdl".
116 -- If hWaitForInput finds anything in the Handle's buffer, it
117 -- immediately returns. If not, it tries to read from the underlying
118 -- OS handle. Notice that for buffered Handles connected to terminals
119 -- this means waiting until a complete line is available.
121 hReady :: Handle -> IO Bool
122 hReady h = hWaitForInput h 0
124 hWaitForInput :: Handle -> Int -> IO Bool
125 hWaitForInput h msecs = do
126 wantReadableHandle "hReady" h $ \ handle_ -> do
127 let ref = haBuffer handle_
130 if not (bufferEmpty buf)
134 r <- throwErrnoIfMinus1Retry "hReady"
135 (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs))
138 foreign import "inputReady"
139 inputReady :: CInt -> CInt -> IO CInt
141 -- ---------------------------------------------------------------------------
144 -- hGetChar reads the next character from a handle,
145 -- blocking until a character is available.
147 hGetChar :: Handle -> IO Char
149 wantReadableHandle "hGetChar" handle $ \handle_ -> do
151 let fd = haFD handle_
152 ref = haBuffer handle_
155 if not (bufferEmpty buf)
156 then hGetcBuffered fd ref buf
160 case haBufferMode handle_ of
162 new_buf <- fillReadBuffer fd True buf
163 hGetcBuffered fd ref new_buf
164 BlockBuffering _ -> do
165 new_buf <- fillReadBuffer fd False buf
166 hGetcBuffered fd ref new_buf
168 -- make use of the minimal buffer we already have
170 r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
171 (read_off (fromIntegral fd) raw 0 1)
175 else do (c,_) <- readCharFromBuffer raw 0
178 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
179 = do (c,r) <- readCharFromBuffer b r
180 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
181 | otherwise = buf{ bufRPtr=r }
182 writeIORef ref new_buf
185 -- ---------------------------------------------------------------------------
188 -- If EOF is reached before EOL is encountered, ignore the EOF and
189 -- return the partial line. Next attempt at calling hGetLine on the
190 -- handle will yield an EOF IO exception though.
192 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
194 hGetLine :: Handle -> IO String
196 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
197 case haBufferMode handle_ of
198 NoBuffering -> return Nothing
200 l <- hGetLineBuffered handle_
202 BlockBuffering _ -> do
203 l <- hGetLineBuffered handle_
206 Nothing -> hGetLineUnBuffered h
210 hGetLineBuffered handle_ = do
211 let ref = haBuffer handle_
213 hGetLineBufferedLoop handle_ ref buf []
216 hGetLineBufferedLoop handle_ ref
217 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
219 -- find the end-of-line character, if there is one
221 | r == w = return (False, w)
223 (c,r') <- readCharFromBuffer raw r
225 then return (True, r) -- NB. not r': don't include the '\n'
228 (eol, off) <- loop raw r
231 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
234 xs <- unpack raw r off
236 then do if w == off + 1
237 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
238 else writeIORef ref buf{ bufRPtr = off + 1 }
239 return (concat (reverse (xs:xss)))
241 maybe_buf <- maybeFillReadBuffer (haFD handle_) True
242 buf{ bufWPtr=0, bufRPtr=0 }
244 -- Nothing indicates we caught an EOF, and we may have a
245 -- partial line to return.
246 Nothing -> let str = concat (reverse (xs:xss)) in
251 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
254 maybeFillReadBuffer fd is_line buf
256 (do buf <- fillReadBuffer fd is_line buf
259 (\e -> do if isEOFError e
264 unpack :: RawBuffer -> Int -> Int -> IO [Char]
265 unpack buf r 0 = return ""
266 unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
269 | i <## r = (## s, acc ##)
271 case readCharArray## buf i s of
272 (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
275 hGetLineUnBuffered :: Handle -> IO String
276 hGetLineUnBuffered h = do
289 if isEOFError err then
299 -- -----------------------------------------------------------------------------
302 -- hGetContents returns the list of characters corresponding to the
303 -- unread portion of the channel or file managed by the handle, which
304 -- is made semi-closed.
306 -- hGetContents on a DuplexHandle only affects the read side: you can
307 -- carry on writing to it afterwards.
309 hGetContents :: Handle -> IO String
310 hGetContents handle =
311 withHandle "hGetContents" handle $ \handle_ ->
312 case haType handle_ of
313 ClosedHandle -> ioe_closedHandle
314 SemiClosedHandle -> ioe_closedHandle
315 AppendHandle -> ioe_notReadable
316 WriteHandle -> ioe_notReadable
317 _ -> do xs <- lazyRead handle
318 return (handle_{ haType=SemiClosedHandle}, xs )
320 -- Note that someone may close the semi-closed handle (or change its
321 -- buffering), so each time these lazy read functions are pulled on,
322 -- they have to check whether the handle has indeed been closed.
324 lazyRead :: Handle -> IO String
327 withHandle "lazyRead" handle $ \ handle_ -> do
328 case haType handle_ of
329 ClosedHandle -> return (handle_, "")
330 SemiClosedHandle -> lazyRead' handle handle_
332 (IOError (Just handle) IllegalOperation "lazyRead"
333 "illegal handle type" Nothing)
335 lazyRead' h handle_ = do
336 let ref = haBuffer handle_
339 -- even a NoBuffering handle can have a char in the buffer...
342 if not (bufferEmpty buf)
343 then lazyReadHaveBuffer h handle_ fd ref buf
346 case haBufferMode handle_ of
348 -- make use of the minimal buffer we already have
351 r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
352 (read_off (fromIntegral fd) raw 0 1)
355 then do handle_ <- hClose_help handle_
357 else do (c,_) <- readCharFromBuffer raw 0
359 return (handle_, c : rest)
361 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
362 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
364 -- we never want to block during the read, so we call fillReadBuffer with
365 -- is_line==True, which tells it to "just read what there is".
366 lazyReadBuffered h handle_ fd ref buf = do
368 (do buf <- fillReadBuffer fd True{-is_line-} buf
369 lazyReadHaveBuffer h handle_ fd ref buf
371 -- all I/O errors are discarded. Additionally, we close the handle.
372 (\e -> do handle_ <- hClose_help handle_
376 lazyReadHaveBuffer h handle_ fd ref buf = do
378 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
379 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
383 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
384 unpackAcc buf r 0 acc = return ""
385 unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
388 | i <## r = (## s, acc ##)
390 case readCharArray## buf i s of
391 (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
393 -- ---------------------------------------------------------------------------
396 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
397 -- managed by `hdl'. Characters may be buffered if buffering is
398 -- enabled for `hdl'.
400 hPutChar :: Handle -> Char -> IO ()
402 c `seq` do -- must evaluate c before grabbing the handle lock
403 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
404 let fd = haFD handle_
405 case haBufferMode handle_ of
406 LineBuffering -> hPutcBuffered handle_ True c
407 BlockBuffering _ -> hPutcBuffered handle_ False c
409 withObject (castCharToCChar c) $ \buf ->
410 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
411 (c_write (fromIntegral fd) buf 1)
415 hPutcBuffered handle_ is_line c = do
416 let ref = haBuffer handle_
419 w' <- writeCharIntoBuffer (bufBuf buf) w c
420 let new_buf = buf{ bufWPtr = w' }
421 if bufferFull new_buf || is_line && c == '\n'
423 flushed_buf <- flushWriteBuffer (haFD handle_) new_buf
424 writeIORef ref flushed_buf
426 writeIORef ref new_buf
429 hPutChars :: Handle -> [Char] -> IO ()
430 hPutChars handle [] = return ()
431 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
433 -- ---------------------------------------------------------------------------
436 -- `hPutStr hdl s' writes the string `s' to the file or
437 -- hannel managed by `hdl', buffering the output if needs be.
439 -- We go to some trouble to avoid keeping the handle locked while we're
440 -- evaluating the string argument to hPutStr, in case doing so triggers another
441 -- I/O operation on the same handle which would lead to deadlock. The classic
444 -- putStr (trace "hello" "world")
446 -- so the basic scheme is this:
448 -- * copy the string into a fresh buffer,
449 -- * "commit" the buffer to the handle.
451 -- Committing may involve simply copying the contents of the new
452 -- buffer into the handle's buffer, flushing one or both buffers, or
453 -- maybe just swapping the buffers over (if the handle's buffer was
454 -- empty). See commitBuffer below.
456 hPutStr :: Handle -> String -> IO ()
457 hPutStr handle str = do
458 buffer_mode <- wantWritableHandle "hPutStr" handle
459 (\ handle_ -> do getSpareBuffer handle_)
461 (NoBuffering, _) -> do
462 hPutChars handle str -- v. slow, but we don't care
463 (LineBuffering, buf) -> do
464 writeLines handle buf str
465 (BlockBuffering _, buf) -> do
466 writeBlocks handle buf str
469 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
470 getSpareBuffer Handle__{haBuffer=ref,
475 NoBuffering -> return (mode, error "no buffer!")
477 bufs <- readIORef spare_ref
480 BufferListCons b rest -> do
481 writeIORef spare_ref rest
482 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
484 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
485 return (mode, new_buf)
488 writeLines :: Handle -> Buffer -> String -> IO ()
489 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
491 shoveString :: Int -> [Char] -> IO ()
492 -- check n == len first, to ensure that shoveString is strict in n.
493 shoveString n cs | n == len = do
494 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
495 writeBlocks hdl new_buf cs
496 shoveString n [] = do
497 commitBuffer hdl raw len n False{-no flush-} True{-release-}
499 shoveString n (c:cs) = do
500 n' <- writeCharIntoBuffer raw n c
505 writeBlocks :: Handle -> Buffer -> String -> IO ()
506 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
508 shoveString :: Int -> [Char] -> IO ()
509 -- check n == len first, to ensure that shoveString is strict in n.
510 shoveString n cs | n == len = do
511 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
512 writeBlocks hdl new_buf cs
513 shoveString n [] = do
514 commitBuffer hdl raw len n False{-no flush-} True{-release-}
516 shoveString n (c:cs) = do
517 n' <- writeCharIntoBuffer raw n c
522 -- -----------------------------------------------------------------------------
523 -- commitBuffer handle buf sz count flush release
525 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
526 -- 'count' bytes of data) to handle (handle must be block or line buffered).
530 -- for block/line buffering,
531 -- 1. If there isn't room in the handle buffer, flush the handle
534 -- 2. If the handle buffer is empty,
536 -- then write buf directly to the device.
537 -- else swap the handle buffer with buf.
539 -- 3. If the handle buffer is non-empty, copy buf into the
540 -- handle buffer. Then, if flush != 0, flush
544 :: Handle -- handle to commit to
545 -> RawBuffer -> Int -- address and size (in bytes) of buffer
546 -> Int -- number of bytes of data in buffer
547 -> Bool -- flush the handle afterward?
548 -> Bool -- release the buffer?
551 commitBuffer hdl raw sz count flush release = do
552 wantWritableHandle "commitAndReleaseBuffer" hdl $
553 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } -> do
556 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
557 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
560 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
564 -- enough room in handle buffer?
565 if (not flush && (size - w > count))
566 -- The > is to be sure that we never exactly fill
567 -- up the buffer, which would require a flush. So
568 -- if copying the new data into the buffer would
569 -- make the buffer full, we just flush the existing
570 -- buffer and the new data immediately, rather than
571 -- copying before flushing.
573 -- not flushing, and there's enough room in the buffer:
574 -- just copy the data in and update bufWPtr.
575 then do memcpy_off old_raw w raw (fromIntegral count)
576 writeIORef ref old_buf{ bufWPtr = w + count }
577 return (newEmptyBuffer raw WriteBuffer sz)
579 -- else, we have to flush
580 else do flushed_buf <- flushWriteBuffer fd old_buf
583 Buffer{ bufBuf=raw, bufState=WriteBuffer,
584 bufRPtr=0, bufWPtr=count, bufSize=sz }
586 -- if: (a) we don't have to flush, and
587 -- (b) size(new buffer) == size(old buffer), and
588 -- (c) new buffer is not full,
589 -- we can just just swap them over...
590 if (not flush && sz == size && count /= sz)
592 writeIORef ref this_buf
595 -- otherwise, we have to flush the new data too,
596 -- and start with a fresh buffer
598 flushWriteBuffer fd this_buf
599 writeIORef ref flushed_buf
600 -- if the sizes were different, then allocate
601 -- a new buffer of the correct size.
603 then return (newEmptyBuffer raw WriteBuffer sz)
604 else allocateBuffer size WriteBuffer
606 -- release the buffer if necessary
607 if release && bufSize buf_ret == size
609 spare_bufs <- readIORef spare_buf_ref
610 writeIORef spare_buf_ref
611 (BufferListCons (bufBuf buf_ret) spare_bufs)
617 foreign import "memcpy_wrap" unsafe
618 memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
620 void *memcpy_wrap(char *dst, HsInt dst_off, const char *src, size_t sz) \
621 { return memcpy(dst+dst_off, src, sz); }
623 -- ---------------------------------------------------------------------------
626 -- Derived action `hPutStrLn hdl str' writes the string `str' to
627 -- the handle `hdl', adding a newline at the end.
629 hPutStrLn :: Handle -> String -> IO ()
630 hPutStrLn hndl str = do
634 -- ---------------------------------------------------------------------------
637 -- Computation `hPrint hdl t' writes the string representation of `t'
638 -- given by the `shows' function to the file or channel managed by `hdl'.
640 hPrint :: Show a => Handle -> a -> IO ()
641 hPrint hdl = hPutStrLn hdl . show