1 {-# OPTIONS -fno-implicit-prelude #-}
5 -- -----------------------------------------------------------------------------
6 -- $Id: PrelIO.hsc,v 1.4 2001/05/24 10:41:13 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 unpack :: RawBuffer -> Int -> Int -> IO [Char]
255 unpack buf r 0 = return ""
256 unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
259 | i <## r = (## s, acc ##)
261 case readCharArray## buf i s of
262 (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
265 hGetLineUnBuffered :: Handle -> IO String
266 hGetLineUnBuffered h = do
279 if isEOFError err then
289 -- -----------------------------------------------------------------------------
292 -- hGetContents returns the list of characters corresponding to the
293 -- unread portion of the channel or file managed by the handle, which
294 -- is made semi-closed.
296 -- hGetContents on a DuplexHandle only affects the read side: you can
297 -- carry on writing to it afterwards.
299 hGetContents :: Handle -> IO String
300 hGetContents handle@(DuplexHandle r w)
301 = withHandle' "hGetContents" handle r (hGetContents' handle)
302 hGetContents handle@(FileHandle m)
303 = withHandle' "hGetContents" handle m (hGetContents' handle)
305 hGetContents' handle handle_ =
306 case haType handle_ of
307 ClosedHandle -> ioe_closedHandle
308 SemiClosedHandle -> ioe_closedHandle
309 AppendHandle -> ioe_notReadable
310 WriteHandle -> ioe_notReadable
311 _ -> do xs <- lazyRead handle
312 return (handle_{ haType=SemiClosedHandle}, xs )
314 -- Note that someone may close the semi-closed handle (or change its
315 -- buffering), so each time these lazy read functions are pulled on,
316 -- they have to check whether the handle has indeed been closed.
318 lazyRead :: Handle -> IO String
321 withHandle_ "lazyRead" handle $ \ handle_ -> do
322 case haType handle_ of
323 ClosedHandle -> return ""
324 SemiClosedHandle -> lazyRead' handle handle_
326 (IOError (Just handle) IllegalOperation "lazyRead"
327 "illegal handle type" Nothing)
329 lazyRead' h handle_ = do
330 let ref = haBuffer handle_
333 -- even a NoBuffering handle can have a char in the buffer...
336 if not (bufferEmpty buf)
337 then lazyReadBuffered h fd ref buf
340 case haBufferMode handle_ of
342 -- make use of the minimal buffer we already have
345 r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
346 (read_off (fromIntegral fd) raw 0 1)
350 else do (c,_) <- readCharFromBuffer raw 0
354 LineBuffering -> lazyReadBuffered h fd ref buf
355 BlockBuffering _ -> lazyReadBuffered h fd ref buf
357 -- we never want to block during the read, so we call fillReadBuffer with
358 -- is_line==True, which tells it to "just read what there is".
359 lazyReadBuffered h fd ref buf = do
362 then maybeFillReadBuffer fd True buf
363 else return (Just buf)
364 case maybe_new_buf of
368 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
369 unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
372 maybeFillReadBuffer fd is_line buf
374 (do buf <- fillReadBuffer fd is_line buf
377 (\e -> if isEOFError e
382 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
383 unpackAcc buf r 0 acc = return ""
384 unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
387 | i <## r = (## s, acc ##)
389 case readCharArray## buf i s of
390 (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
392 -- ---------------------------------------------------------------------------
395 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
396 -- managed by `hdl'. Characters may be buffered if buffering is
397 -- enabled for `hdl'.
399 hPutChar :: Handle -> Char -> IO ()
401 c `seq` do -- must evaluate c before grabbing the handle lock
402 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
403 let fd = haFD handle_
404 case haBufferMode handle_ of
405 LineBuffering -> hPutcBuffered handle_ True c
406 BlockBuffering _ -> hPutcBuffered handle_ False c
408 withObject (castCharToCChar c) $ \buf ->
409 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
410 (c_write (fromIntegral fd) buf 1)
414 hPutcBuffered handle_ is_line c = do
415 let ref = haBuffer handle_
418 w' <- writeCharIntoBuffer (bufBuf buf) w c
419 let new_buf = buf{ bufWPtr = w' }
420 if bufferFull new_buf || is_line && c == '\n'
422 flushed_buf <- flushWriteBuffer (haFD handle_) new_buf
423 writeIORef ref flushed_buf
425 writeIORef ref new_buf
428 hPutChars :: Handle -> [Char] -> IO ()
429 hPutChars handle [] = return ()
430 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
432 -- ---------------------------------------------------------------------------
435 -- `hPutStr hdl s' writes the string `s' to the file or
436 -- hannel managed by `hdl', buffering the output if needs be.
438 -- We go to some trouble to avoid keeping the handle locked while we're
439 -- evaluating the string argument to hPutStr, in case doing so triggers another
440 -- I/O operation on the same handle which would lead to deadlock. The classic
443 -- putStr (trace "hello" "world")
445 -- so the basic scheme is this:
447 -- * copy the string into a fresh buffer,
448 -- * "commit" the buffer to the handle.
450 -- Committing may involve simply copying the contents of the new
451 -- buffer into the handle's buffer, flushing one or both buffers, or
452 -- maybe just swapping the buffers over (if the handle's buffer was
453 -- empty). See commitBuffer below.
455 hPutStr :: Handle -> String -> IO ()
456 hPutStr handle str = do
457 buffer_mode <- wantWritableHandle "hPutStr" handle
458 (\ handle_ -> do getSpareBuffer handle_)
460 (NoBuffering, _) -> do
461 hPutChars handle str -- v. slow, but we don't care
462 (LineBuffering, buf) -> do
463 writeLines handle buf str
464 (BlockBuffering _, buf) -> do
465 writeBlocks handle buf str
468 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
469 getSpareBuffer Handle__{haBuffer=ref,
474 NoBuffering -> return (mode, error "no buffer!")
476 bufs <- readIORef spare_ref
479 BufferListCons b rest -> do
480 writeIORef spare_ref rest
481 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
483 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
484 return (mode, new_buf)
487 writeLines :: Handle -> Buffer -> String -> IO ()
488 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
490 shoveString :: Int -> [Char] -> IO ()
491 -- check n == len first, to ensure that shoveString is strict in n.
492 shoveString n cs | n == len = do
493 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
494 writeBlocks hdl new_buf cs
495 shoveString n [] = do
496 commitBuffer hdl raw len n False{-no flush-} True{-release-}
498 shoveString n (c:cs) = do
499 n' <- writeCharIntoBuffer raw n c
504 writeBlocks :: Handle -> Buffer -> String -> IO ()
505 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
507 shoveString :: Int -> [Char] -> IO ()
508 -- check n == len first, to ensure that shoveString is strict in n.
509 shoveString n cs | n == len = do
510 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
511 writeBlocks hdl new_buf cs
512 shoveString n [] = do
513 commitBuffer hdl raw len n False{-no flush-} True{-release-}
515 shoveString n (c:cs) = do
516 n' <- writeCharIntoBuffer raw n c
521 -- -----------------------------------------------------------------------------
522 -- commitBuffer handle buf sz count flush release
524 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
525 -- 'count' bytes of data) to handle (handle must be block or line buffered).
529 -- for block/line buffering,
530 -- 1. If there isn't room in the handle buffer, flush the handle
533 -- 2. If the handle buffer is empty,
535 -- then write buf directly to the device.
536 -- else swap the handle buffer with buf.
538 -- 3. If the handle buffer is non-empty, copy buf into the
539 -- handle buffer. Then, if flush != 0, flush
543 :: Handle -- handle to commit to
544 -> RawBuffer -> Int -- address and size (in bytes) of buffer
545 -> Int -- number of bytes of data in buffer
546 -> Bool -- flush the handle afterward?
547 -> Bool -- release the buffer?
550 commitBuffer hdl raw sz count flush release = do
551 wantWritableHandle "commitAndReleaseBuffer" hdl $
552 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } -> do
555 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
556 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
559 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
563 -- enough room in handle buffer?
564 if (not flush && (size - w > count))
565 -- The > is to be sure that we never exactly fill
566 -- up the buffer, which would require a flush. So
567 -- if copying the new data into the buffer would
568 -- make the buffer full, we just flush the existing
569 -- buffer and the new data immediately, rather than
570 -- copying before flushing.
572 -- not flushing, and there's enough room in the buffer:
573 -- just copy the data in and update bufWPtr.
574 then do memcpy_off old_raw w raw (fromIntegral count)
575 writeIORef ref old_buf{ bufWPtr = w + count }
576 return (newEmptyBuffer raw WriteBuffer sz)
578 -- else, we have to flush
579 else do flushed_buf <- flushWriteBuffer fd old_buf
582 Buffer{ bufBuf=raw, bufState=WriteBuffer,
583 bufRPtr=0, bufWPtr=count, bufSize=sz }
585 -- if: (a) we don't have to flush, and
586 -- (b) size(new buffer) == size(old buffer), and
587 -- (c) new buffer is not full,
588 -- we can just just swap them over...
589 if (not flush && sz == size && count /= sz)
591 writeIORef ref this_buf
594 -- otherwise, we have to flush the new data too,
595 -- and start with a fresh buffer
597 flushWriteBuffer fd this_buf
598 writeIORef ref flushed_buf
599 -- if the sizes were different, then allocate
600 -- a new buffer of the correct size.
602 then return (newEmptyBuffer raw WriteBuffer sz)
603 else allocateBuffer size WriteBuffer
605 -- release the buffer if necessary
606 if release && bufSize buf_ret == size
608 spare_bufs <- readIORef spare_buf_ref
609 writeIORef spare_buf_ref
610 (BufferListCons (bufBuf buf_ret) spare_bufs)
616 foreign import "memcpy_wrap" unsafe
617 memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
619 void *memcpy_wrap(char *dst, int dst_off, char *src, size_t sz) \
620 { return memcpy(dst+dst_off, src, sz); }
622 -- ---------------------------------------------------------------------------
625 -- Derived action `hPutStrLn hdl str' writes the string `str' to
626 -- the handle `hdl', adding a newline at the end.
628 hPutStrLn :: Handle -> String -> IO ()
629 hPutStrLn hndl str = do
633 -- ---------------------------------------------------------------------------
636 -- Computation `hPrint hdl t' writes the string representation of `t'
637 -- given by the `shows' function to the file or channel managed by `hdl'.
639 hPrint :: Show a => Handle -> a -> IO ()
640 hPrint hdl = hPutStrLn hdl . show