ghc/lib/std/PrelIO.hs

   1 {-# OPTIONS -fno-implicit-prelude -#include "PrelIOUtils.h" #-}
   2
   3 #undef DEBUG_DUMP
   4
   5 -- -----------------------------------------------------------------------------
   6 -- $Id: PrelIO.hs,v 1.7 2001/12/27 11:26:03 sof Exp $
   7 --
   8 -- (c) The University of Glasgow, 1992-2001
   9 --
  10 -- Module PrelIO
  11
  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
  15 -- module IO.
  16
  17 module PrelIO (
  18    putChar, putStr, putStrLn, print, getChar, getLine, getContents,
  19    interact, readFile, writeFile, appendFile, readLn, readIO, hReady,
  20    hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
  21    hPutStrLn, hPrint,
  22    commitBuffer',       -- hack, see below
  23    hGetcBuffered,       -- needed by ghc/compiler/utils/StringBuffer.lhs
  24
  25     -- helpers
  26    memcpy_ba_ba,
  27    memcpy_ba_ptr,
  28    memcpy_ptr_ba,
  29    memcpy_ptr_ptr
  30  ) where
  31
  32 import PrelBase
  33
  34 import PrelPosix
  35 import PrelMarshalUtils
  36 import PrelStorable
  37 import PrelCError
  38 import PrelCString
  39 import PrelCTypes
  40 import PrelCTypesISO
  41
  42 import PrelIOBase
  43 import PrelHandle       -- much of the real stuff is in here
  44
  45 import PrelMaybe
  46 import PrelReal
  47 import PrelNum
  48 import PrelRead
  49 import PrelShow
  50 import PrelMaybe        ( Maybe(..) )
  51 import PrelPtr
  52 import PrelList
  53 import PrelException    ( ioError, catch, throw )
  54 import PrelConc
  55
  56 -- -----------------------------------------------------------------------------
  57 -- Standard IO
  58
  59 putChar         :: Char -> IO ()
  60 putChar c       =  hPutChar stdout c
  61
  62 putStr          :: String -> IO ()
  63 putStr s        =  hPutStr stdout s
  64
  65 putStrLn        :: String -> IO ()
  66 putStrLn s      =  do putStr s
  67                       putChar '\n'
  68
  69 print           :: Show a => a -> IO ()
  70 print x         =  putStrLn (show x)
  71
  72 getChar         :: IO Char
  73 getChar         =  hGetChar stdin
  74
  75 getLine         :: IO String
  76 getLine         =  hGetLine stdin
  77
  78 getContents     :: IO String
  79 getContents     =  hGetContents stdin
  80
  81 interact        ::  (String -> String) -> IO ()
  82 interact f      =   do s <- getContents
  83                        putStr (f s)
  84
  85 readFile        :: FilePath -> IO String
  86 readFile name   =  openFile name ReadMode >>= hGetContents
  87
  88 writeFile       :: FilePath -> String -> IO ()
  89 writeFile name str = do
  90     hdl <- openFile name WriteMode
  91     hPutStr hdl str
  92     hClose hdl
  93
  94 appendFile      :: FilePath -> String -> IO ()
  95 appendFile name str = do
  96     hdl <- openFile name AppendMode
  97     hPutStr hdl str
  98     hClose hdl
  99
 100 readLn          :: Read a => IO a
 101 readLn          =  do l <- getLine
 102                       r <- readIO l
 103                       return r
 104
 105   -- raises an exception instead of an error
 106 readIO          :: Read a => String -> IO a
 107 readIO s        =  case (do { (x,t) <- reads s ;
 108                               ("","") <- lex t ;
 109                               return x }) of
 110 #ifndef NEW_READS_REP
 111                         [x]    -> return x
 112                         []     -> ioError (userError "Prelude.readIO: no parse")
 113                         _      -> ioError (userError "Prelude.readIO: ambiguous parse")
 114 #else
 115                         Just x -> return x
 116                         Nothing  -> ioError (userError "Prelude.readIO: no parse")
 117 #endif
 118
 119 -- ---------------------------------------------------------------------------
 120 -- Simple input operations
 121
 122 -- Computation "hReady hdl" indicates whether at least
 123 -- one item is available for input from handle "hdl".
 124
 125 -- If hWaitForInput finds anything in the Handle's buffer, it
 126 -- immediately returns.  If not, it tries to read from the underlying
 127 -- OS handle. Notice that for buffered Handles connected to terminals
 128 -- this means waiting until a complete line is available.
 129
 130 hReady :: Handle -> IO Bool
 131 hReady h = hWaitForInput h 0
 132
 133 hWaitForInput :: Handle -> Int -> IO Bool
 134 hWaitForInput h msecs = do
 135   wantReadableHandle "hReady" h $ \ handle_ -> do
 136   let ref = haBuffer handle_
 137   buf <- readIORef ref
 138
 139   if not (bufferEmpty buf)
 140         then return True
 141         else do
 142
 143   r <- throwErrnoIfMinus1Retry "hReady"
 144           (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
 145   return (r /= 0)
 146
 147 foreign import "inputReady" unsafe
 148   inputReady :: CInt -> CInt -> Bool -> IO CInt
 149
 150 -- ---------------------------------------------------------------------------
 151 -- hGetChar
 152
 153 -- hGetChar reads the next character from a handle,
 154 -- blocking until a character is available.
 155
 156 hGetChar :: Handle -> IO Char
 157 hGetChar handle =
 158   wantReadableHandle "hGetChar" handle $ \handle_ -> do
 159
 160   let fd = haFD handle_
 161       ref = haBuffer handle_
 162
 163   buf <- readIORef ref
 164   if not (bufferEmpty buf)
 165         then hGetcBuffered fd ref buf
 166         else do
 167
 168   -- buffer is empty.
 169   case haBufferMode handle_ of
 170     LineBuffering    -> do
 171         new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
 172         hGetcBuffered fd ref new_buf
 173     BlockBuffering _ -> do
 174         new_buf <- fillReadBuffer fd False (haIsStream handle_) buf
 175         hGetcBuffered fd ref new_buf
 176     NoBuffering -> do
 177         -- make use of the minimal buffer we already have
 178         let raw = bufBuf buf
 179         r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
 180                 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
 181                 (threadWaitRead fd)
 182         if r == 0
 183            then ioe_EOF
 184            else do (c,_) <- readCharFromBuffer raw 0
 185                    return c
 186
 187 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
 188  = do (c,r) <- readCharFromBuffer b r
 189       let new_buf | r == w    = buf{ bufRPtr=0, bufWPtr=0 }
 190                   | otherwise = buf{ bufRPtr=r }
 191       writeIORef ref new_buf
 192       return c
 193
 194 -- ---------------------------------------------------------------------------
 195 -- hGetLine
 196
 197 -- If EOF is reached before EOL is encountered, ignore the EOF and
 198 -- return the partial line. Next attempt at calling hGetLine on the
 199 -- handle will yield an EOF IO exception though.
 200
 201 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
 202 -- the duration.
 203 hGetLine :: Handle -> IO String
 204 hGetLine h = do
 205   m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
 206         case haBufferMode handle_ of
 207            NoBuffering      -> return Nothing
 208            LineBuffering    -> do
 209               l <- hGetLineBuffered handle_
 210               return (Just l)
 211            BlockBuffering _ -> do
 212               l <- hGetLineBuffered handle_
 213               return (Just l)
 214   case m of
 215         Nothing -> hGetLineUnBuffered h
 216         Just l  -> return l
 217
 218
 219 hGetLineBuffered handle_ = do
 220   let ref = haBuffer handle_
 221   buf <- readIORef ref
 222   hGetLineBufferedLoop handle_ ref buf []
 223
 224
 225 hGetLineBufferedLoop handle_ ref
 226         buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
 227   let
 228         -- find the end-of-line character, if there is one
 229         loop raw r
 230            | r == w = return (False, w)
 231            | otherwise =  do
 232                 (c,r') <- readCharFromBuffer raw r
 233                 if c == '\n'
 234                    then return (True, r) -- NB. not r': don't include the '\n'
 235                    else loop raw r'
 236   in do
 237   (eol, off) <- loop raw r
 238
 239 #ifdef DEBUG_DUMP
 240   puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
 241 #endif
 242
 243   xs <- unpack raw r off
 244   if eol
 245         then do if w == off + 1
 246                    then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 247                    else writeIORef ref buf{ bufRPtr = off + 1 }
 248                 return (concat (reverse (xs:xss)))
 249         else do
 250              maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
 251                                 buf{ bufWPtr=0, bufRPtr=0 }
 252              case maybe_buf of
 253                 -- Nothing indicates we caught an EOF, and we may have a
 254                 -- partial line to return.
 255                 Nothing -> let str = concat (reverse (xs:xss)) in
 256                            if not (null str)
 257                               then return str
 258                               else ioe_EOF
 259                 Just new_buf ->
 260                      hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
 261
 262
 263 maybeFillReadBuffer fd is_line is_stream buf
 264   = catch
 265      (do buf <- fillReadBuffer fd is_line is_stream buf
 266          return (Just buf)
 267      )
 268      (\e -> do if isEOFError e
 269                   then return Nothing
 270                   else throw e)
 271
 272
 273 unpack :: RawBuffer -> Int -> Int -> IO [Char]
 274 unpack buf r 0   = return ""
 275 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
 276    where
 277     unpack acc i s
 278      | i <# r  = (# s, acc #)
 279      | otherwise =
 280           case readCharArray# buf i s of
 281             (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
 282
 283
 284 hGetLineUnBuffered :: Handle -> IO String
 285 hGetLineUnBuffered h = do
 286   c <- hGetChar h
 287   if c == '\n' then
 288      return ""
 289    else do
 290     l <- getRest
 291     return (c:l)
 292  where
 293   getRest = do
 294     c <-
 295       catch
 296         (hGetChar h)
 297         (\ err -> do
 298           if isEOFError err then
 299              return '\n'
 300            else
 301              ioError err)
 302     if c == '\n' then
 303        return ""
 304      else do
 305        s <- getRest
 306        return (c:s)
 307
 308 -- -----------------------------------------------------------------------------
 309 -- hGetContents
 310
 311 -- hGetContents returns the list of characters corresponding to the
 312 -- unread portion of the channel or file managed by the handle, which
 313 -- is made semi-closed.
 314
 315 -- hGetContents on a DuplexHandle only affects the read side: you can
 316 -- carry on writing to it afterwards.
 317
 318 hGetContents :: Handle -> IO String
 319 hGetContents handle =
 320     withHandle "hGetContents" handle $ \handle_ ->
 321     case haType handle_ of
 322       ClosedHandle         -> ioe_closedHandle
 323       SemiClosedHandle     -> ioe_closedHandle
 324       AppendHandle         -> ioe_notReadable
 325       WriteHandle          -> ioe_notReadable
 326       _ -> do xs <- lazyRead handle
 327               return (handle_{ haType=SemiClosedHandle}, xs )
 328
 329 -- Note that someone may close the semi-closed handle (or change its
 330 -- buffering), so each time these lazy read functions are pulled on,
 331 -- they have to check whether the handle has indeed been closed.
 332
 333 lazyRead :: Handle -> IO String
 334 lazyRead handle =
 335    unsafeInterleaveIO $
 336         withHandle "lazyRead" handle $ \ handle_ -> do
 337         case haType handle_ of
 338           ClosedHandle     -> return (handle_, "")
 339           SemiClosedHandle -> lazyRead' handle handle_
 340           _ -> ioException
 341                   (IOError (Just handle) IllegalOperation "lazyRead"
 342                         "illegal handle type" Nothing)
 343
 344 lazyRead' h handle_ = do
 345   let ref = haBuffer handle_
 346       fd  = haFD handle_
 347
 348   -- even a NoBuffering handle can have a char in the buffer...
 349   -- (see hLookAhead)
 350   buf <- readIORef ref
 351   if not (bufferEmpty buf)
 352         then lazyReadHaveBuffer h handle_ fd ref buf
 353         else do
 354
 355   case haBufferMode handle_ of
 356      NoBuffering      -> do
 357         -- make use of the minimal buffer we already have
 358         let raw = bufBuf buf
 359         r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
 360                 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
 361                 (threadWaitRead fd)
 362         if r == 0
 363            then do handle_ <- hClose_help handle_
 364                    return (handle_, "")
 365            else do (c,_) <- readCharFromBuffer raw 0
 366                    rest <- lazyRead h
 367                    return (handle_, c : rest)
 368
 369      LineBuffering    -> lazyReadBuffered h handle_ fd ref buf
 370      BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
 371
 372 -- we never want to block during the read, so we call fillReadBuffer with
 373 -- is_line==True, which tells it to "just read what there is".
 374 lazyReadBuffered h handle_ fd ref buf = do
 375    catch
 376         (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
 377             lazyReadHaveBuffer h handle_ fd ref buf
 378         )
 379         -- all I/O errors are discarded.  Additionally, we close the handle.
 380         (\e -> do handle_ <- hClose_help handle_
 381                   return (handle_, "")
 382         )
 383
 384 lazyReadHaveBuffer h handle_ fd ref buf = do
 385    more <- lazyRead h
 386    writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 387    s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
 388    return (handle_, s)
 389
 390
 391 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
 392 unpackAcc buf r 0 acc  = return ""
 393 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
 394    where
 395     unpack acc i s
 396      | i <# r  = (# s, acc #)
 397      | otherwise =
 398           case readCharArray# buf i s of
 399             (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
 400
 401 -- ---------------------------------------------------------------------------
 402 -- hPutChar
 403
 404 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
 405 -- managed by `hdl'.  Characters may be buffered if buffering is
 406 -- enabled for `hdl'.
 407
 408 hPutChar :: Handle -> Char -> IO ()
 409 hPutChar handle c =
 410     c `seq` do   -- must evaluate c before grabbing the handle lock
 411     wantWritableHandle "hPutChar" handle $ \ handle_  -> do
 412     let fd = haFD handle_
 413     case haBufferMode handle_ of
 414         LineBuffering    -> hPutcBuffered handle_ True  c
 415         BlockBuffering _ -> hPutcBuffered handle_ False c
 416         NoBuffering      ->
 417                 withObject (castCharToCChar c) $ \buf ->
 418                 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
 419                    (write_off (fromIntegral fd) (haIsStream handle_) buf 0 1)
 420                    (threadWaitWrite fd)
 421
 422
 423 hPutcBuffered handle_ is_line c = do
 424   let ref = haBuffer handle_
 425   buf <- readIORef ref
 426   let w = bufWPtr buf
 427   w'  <- writeCharIntoBuffer (bufBuf buf) w c
 428   let new_buf = buf{ bufWPtr = w' }
 429   if bufferFull new_buf || is_line && c == '\n'
 430      then do
 431         flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
 432         writeIORef ref flushed_buf
 433      else do
 434         writeIORef ref new_buf
 435
 436
 437 hPutChars :: Handle -> [Char] -> IO ()
 438 hPutChars handle [] = return ()
 439 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
 440
 441 -- ---------------------------------------------------------------------------
 442 -- hPutStr
 443
 444 -- `hPutStr hdl s' writes the string `s' to the file or
 445 -- hannel managed by `hdl', buffering the output if needs be.
 446
 447 -- We go to some trouble to avoid keeping the handle locked while we're
 448 -- evaluating the string argument to hPutStr, in case doing so triggers another
 449 -- I/O operation on the same handle which would lead to deadlock.  The classic
 450 -- case is
 451 --
 452 --              putStr (trace "hello" "world")
 453 --
 454 -- so the basic scheme is this:
 455 --
 456 --      * copy the string into a fresh buffer,
 457 --      * "commit" the buffer to the handle.
 458 --
 459 -- Committing may involve simply copying the contents of the new
 460 -- buffer into the handle's buffer, flushing one or both buffers, or
 461 -- maybe just swapping the buffers over (if the handle's buffer was
 462 -- empty).  See commitBuffer below.
 463
 464 hPutStr :: Handle -> String -> IO ()
 465 hPutStr handle str = do
 466     buffer_mode <- wantWritableHandle "hPutStr" handle
 467                         (\ handle_ -> do getSpareBuffer handle_)
 468     case buffer_mode of
 469        (NoBuffering, _) -> do
 470             hPutChars handle str        -- v. slow, but we don't care
 471        (LineBuffering, buf) -> do
 472             writeLines handle buf str
 473        (BlockBuffering _, buf) -> do
 474             writeBlocks handle buf str
 475
 476
 477 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
 478 getSpareBuffer Handle__{haBuffer=ref,
 479                         haBuffers=spare_ref,
 480                         haBufferMode=mode}
 481  = do
 482    case mode of
 483      NoBuffering -> return (mode, error "no buffer!")
 484      _ -> do
 485           bufs <- readIORef spare_ref
 486           buf  <- readIORef ref
 487           case bufs of
 488             BufferListCons b rest -> do
 489                 writeIORef spare_ref rest
 490                 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
 491             BufferListNil -> do
 492                 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
 493                 return (mode, new_buf)
 494
 495
 496 writeLines :: Handle -> Buffer -> String -> IO ()
 497 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
 498   let
 499    shoveString :: Int -> [Char] -> IO ()
 500         -- check n == len first, to ensure that shoveString is strict in n.
 501    shoveString n cs | n == len = do
 502         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 503         writeLines hdl new_buf cs
 504    shoveString n [] = do
 505         commitBuffer hdl raw len n False{-no flush-} True{-release-}
 506         return ()
 507    shoveString n (c:cs) = do
 508         n' <- writeCharIntoBuffer raw n c
 509         if (c == '\n')
 510            then do
 511                 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
 512                 writeLines hdl new_buf cs
 513            else
 514                 shoveString n' cs
 515   in
 516   shoveString 0 s
 517
 518 writeBlocks :: Handle -> Buffer -> String -> IO ()
 519 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
 520   let
 521    shoveString :: Int -> [Char] -> IO ()
 522         -- check n == len first, to ensure that shoveString is strict in n.
 523    shoveString n cs | n == len = do
 524         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 525         writeBlocks hdl new_buf cs
 526    shoveString n [] = do
 527         commitBuffer hdl raw len n False{-no flush-} True{-release-}
 528         return ()
 529    shoveString n (c:cs) = do
 530         n' <- writeCharIntoBuffer raw n c
 531         shoveString n' cs
 532   in
 533   shoveString 0 s
 534
 535 -- -----------------------------------------------------------------------------
 536 -- commitBuffer handle buf sz count flush release
 537 --
 538 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
 539 -- 'count' bytes of data) to handle (handle must be block or line buffered).
 540 --
 541 -- Implementation:
 542 --
 543 --    for block/line buffering,
 544 --       1. If there isn't room in the handle buffer, flush the handle
 545 --          buffer.
 546 --
 547 --       2. If the handle buffer is empty,
 548 --               if flush,
 549 --                   then write buf directly to the device.
 550 --                   else swap the handle buffer with buf.
 551 --
 552 --       3. If the handle buffer is non-empty, copy buf into the
 553 --          handle buffer.  Then, if flush != 0, flush
 554 --          the buffer.
 555
 556 commitBuffer
 557         :: Handle                       -- handle to commit to
 558         -> RawBuffer -> Int             -- address and size (in bytes) of buffer
 559         -> Int                          -- number of bytes of data in buffer
 560         -> Bool                         -- True <=> flush the handle afterward
 561         -> Bool                         -- release the buffer?
 562         -> IO Buffer
 563
 564 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
 565   wantWritableHandle "commitAndReleaseBuffer" hdl $
 566      commitBuffer' hdl raw sz count flush release
 567
 568 -- Explicitly lambda-lift this function to subvert GHC's full laziness
 569 -- optimisations, which otherwise tends to float out subexpressions
 570 -- past the \handle, which is really a pessimisation in this case because
 571 -- that lambda is a one-shot lambda.
 572 --
 573 -- Don't forget to export the function, to stop it being inlined too
 574 -- (this appears to be better than NOINLINE, because the strictness
 575 -- analyser still gets to worker-wrapper it).
 576 --
 577 -- This hack is a fairly big win for hPutStr performance.  --SDM 18/9/2001
 578 --
 579 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
 580   handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
 581
 582 #ifdef DEBUG_DUMP
 583       puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
 584             ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
 585 #endif
 586
 587       old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 588           <- readIORef ref
 589
 590       buf_ret <-
 591         -- enough room in handle buffer?
 592          if (not flush && (size - w > count))
 593                 -- The > is to be sure that we never exactly fill
 594                 -- up the buffer, which would require a flush.  So
 595                 -- if copying the new data into the buffer would
 596                 -- make the buffer full, we just flush the existing
 597                 -- buffer and the new data immediately, rather than
 598                 -- copying before flushing.
 599
 600                 -- not flushing, and there's enough room in the buffer:
 601                 -- just copy the data in and update bufWPtr.
 602             then do memcpy_ba_ba old_raw w raw 0 (fromIntegral count)
 603                     writeIORef ref old_buf{ bufWPtr = w + count }
 604                     return (newEmptyBuffer raw WriteBuffer sz)
 605
 606                 -- else, we have to flush
 607             else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
 608
 609                     let this_buf =
 610                             Buffer{ bufBuf=raw, bufState=WriteBuffer,
 611                                     bufRPtr=0, bufWPtr=count, bufSize=sz }
 612
 613                         -- if:  (a) we don't have to flush, and
 614                         --      (b) size(new buffer) == size(old buffer), and
 615                         --      (c) new buffer is not full,
 616                         -- we can just just swap them over...
 617                     if (not flush && sz == size && count /= sz)
 618                         then do
 619                           writeIORef ref this_buf
 620                           return flushed_buf
 621
 622                         -- otherwise, we have to flush the new data too,
 623                         -- and start with a fresh buffer
 624                         else do
 625                           flushWriteBuffer fd (haIsStream handle_) this_buf
 626                           writeIORef ref flushed_buf
 627                             -- if the sizes were different, then allocate
 628                             -- a new buffer of the correct size.
 629                           if sz == size
 630                              then return (newEmptyBuffer raw WriteBuffer sz)
 631                              else allocateBuffer size WriteBuffer
 632
 633       -- release the buffer if necessary
 634       case buf_ret of
 635         Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
 636           if release && buf_ret_sz == size
 637             then do
 638               spare_bufs <- readIORef spare_buf_ref
 639               writeIORef spare_buf_ref
 640                 (BufferListCons buf_ret_raw spare_bufs)
 641               return buf_ret
 642             else
 643               return buf_ret
 644
 645
 646 foreign import "prel_PrelIO_memcpy" unsafe
 647    memcpy_ba_ba :: RawBuffer -> Int -> RawBuffer -> Int -> CSize -> IO (Ptr ())
 648
 649 foreign import "prel_PrelIO_memcpy" unsafe
 650    memcpy_ba_ptr :: RawBuffer -> Int -> Ptr a -> Int -> CSize -> IO (Ptr ())
 651
 652 foreign import "prel_PrelIO_memcpy" unsafe
 653    memcpy_ptr_ba :: Ptr a -> Int -> RawBuffer -> Int -> CSize -> IO (Ptr ())
 654
 655 foreign import "prel_PrelIO_memcpy" unsafe
 656    memcpy_ptr_ptr :: Ptr a -> Int -> Ptr a -> Int -> CSize -> IO (Ptr ())
 657
 658 -- ---------------------------------------------------------------------------
 659 -- hPutStrLn
 660
 661 -- Derived action `hPutStrLn hdl str' writes the string `str' to
 662 -- the handle `hdl', adding a newline at the end.
 663
 664 hPutStrLn :: Handle -> String -> IO ()
 665 hPutStrLn hndl str = do
 666  hPutStr  hndl str
 667  hPutChar hndl '\n'
 668
 669 -- ---------------------------------------------------------------------------
 670 -- hPrint
 671
 672 -- Computation `hPrint hdl t' writes the string representation of `t'
 673 -- given by the `shows' function to the file or channel managed by `hdl'.
 674
 675 hPrint :: Show a => Handle -> a -> IO ()
 676 hPrint hdl = hPutStrLn hdl . show