GHC/IO/Handle/Text.hs

   1 {-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
   2 {-# OPTIONS_GHC -XRecordWildCards -XBangPatterns #-}
   3 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
   4 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
   5 {-# OPTIONS_HADDOCK hide #-}
   6
   7 -----------------------------------------------------------------------------
   8 -- |
   9 -- Module      :  GHC.IO.Text
  10 -- Copyright   :  (c) The University of Glasgow, 1992-2008
  11 -- License     :  see libraries/base/LICENSE
  12 --
  13 -- Maintainer  :  libraries@haskell.org
  14 -- Stability   :  internal
  15 -- Portability :  non-portable
  16 --
  17 -- String I\/O functions
  18 --
  19 -----------------------------------------------------------------------------
  20
  21 -- #hide
  22 module GHC.IO.Handle.Text (
  23    hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
  24    commitBuffer',       -- hack, see below
  25    hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
  26    memcpy,
  27  ) where
  28
  29 import GHC.IO
  30 import GHC.IO.FD
  31 import GHC.IO.Buffer
  32 import qualified GHC.IO.BufferedIO as Buffered
  33 import GHC.IO.Exception
  34 import GHC.IO.Handle.Types
  35 import GHC.IO.Handle.Internals
  36 import qualified GHC.IO.Device as IODevice
  37 import qualified GHC.IO.Device as RawIO
  38
  39 import Foreign
  40 import Foreign.C
  41
  42 import Data.Typeable
  43 import System.IO.Error
  44 import Data.Maybe
  45 import Control.Monad
  46
  47 import GHC.IORef
  48 import GHC.Base
  49 import GHC.Real
  50 import GHC.Num
  51 import GHC.Show
  52 import GHC.List
  53
  54 -- ---------------------------------------------------------------------------
  55 -- Simple input operations
  56
  57 -- If hWaitForInput finds anything in the Handle's buffer, it
  58 -- immediately returns.  If not, it tries to read from the underlying
  59 -- OS handle. Notice that for buffered Handles connected to terminals
  60 -- this means waiting until a complete line is available.
  61
  62 -- | Computation 'hWaitForInput' @hdl t@
  63 -- waits until input is available on handle @hdl@.
  64 -- It returns 'True' as soon as input is available on @hdl@,
  65 -- or 'False' if no input is available within @t@ milliseconds.
  66 --
  67 -- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
  68 --
  69 -- This operation may fail with:
  70 --
  71 --  * 'isEOFError' if the end of file has been reached.
  72 --
  73 -- NOTE for GHC users: unless you use the @-threaded@ flag,
  74 -- @hWaitForInput t@ where @t >= 0@ will block all other Haskell
  75 -- threads for the duration of the call.  It behaves like a
  76 -- @safe@ foreign call in this respect.
  77
  78 hWaitForInput :: Handle -> Int -> IO Bool
  79 hWaitForInput h msecs = do
  80   wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do
  81   buf <- readIORef haCharBuffer
  82
  83   if not (isEmptyBuffer buf)
  84         then return True
  85         else do
  86
  87   if msecs < 0
  88         then do buf' <- readTextDevice handle_ buf
  89                 writeIORef haCharBuffer buf'
  90                 return True
  91         else do r <- IODevice.ready haDevice False{-read-} msecs
  92                 if r then do -- Call hLookAhead' to throw an EOF
  93                                   -- exception if appropriate
  94                                   hLookAhead_ handle_
  95                                   return True
  96                           else return False
  97
  98 -- ---------------------------------------------------------------------------
  99 -- hGetChar
 100
 101 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
 102 -- channel managed by @hdl@, blocking until a character is available.
 103 --
 104 -- This operation may fail with:
 105 --
 106 --  * 'isEOFError' if the end of file has been reached.
 107
 108 hGetChar :: Handle -> IO Char
 109 hGetChar handle =
 110   wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do
 111
 112   -- buffering mode makes no difference: we just read whatever is available
 113   -- from the device (blocking only if there is nothing available), and then
 114   -- return the first character.
 115   -- See [note Buffered Reading] in GHC.IO.Handle.Types
 116   buf0 <- readIORef haCharBuffer
 117
 118   buf1 <- if isEmptyBuffer buf0
 119              then readTextDevice handle_ buf0
 120              else return buf0
 121
 122   (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)
 123   let buf2 = bufferAdjustL i buf1
 124
 125   if haInputNL == CRLF && c1 == '\r'
 126      then do
 127             mbuf3 <- if isEmptyBuffer buf2
 128                       then maybeFillReadBuffer handle_ buf2
 129                       else return (Just buf2)
 130
 131             case mbuf3 of
 132                -- EOF, so just return the '\r' we have
 133                Nothing -> do
 134                   writeIORef haCharBuffer buf2
 135                   return '\r'
 136                Just buf3 -> do
 137                   (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)
 138                   if c2 == '\n'
 139                      then do
 140                        writeIORef haCharBuffer (bufferAdjustL i2 buf3)
 141                        return '\n'
 142                      else do
 143                        -- not a \r\n sequence, so just return the \r
 144                        writeIORef haCharBuffer buf3
 145                        return '\r'
 146      else do
 147             writeIORef haCharBuffer buf2
 148             return c1
 149
 150 -- ---------------------------------------------------------------------------
 151 -- hGetLine
 152
 153 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
 154 -- the duration.
 155
 156 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
 157 -- channel managed by @hdl@.
 158 --
 159 -- This operation may fail with:
 160 --
 161 --  * 'isEOFError' if the end of file is encountered when reading
 162 --    the /first/ character of the line.
 163 --
 164 -- If 'hGetLine' encounters end-of-file at any other point while reading
 165 -- in a line, it is treated as a line terminator and the (partial)
 166 -- line is returned.
 167
 168 hGetLine :: Handle -> IO String
 169 hGetLine h =
 170   wantReadableHandle_ "hGetLine" h $ \ handle_ -> do
 171      hGetLineBuffered handle_
 172
 173 hGetLineBuffered :: Handle__ -> IO String
 174 hGetLineBuffered handle_@Handle__{..} = do
 175   buf <- readIORef haCharBuffer
 176   hGetLineBufferedLoop handle_ buf []
 177
 178 hGetLineBufferedLoop :: Handle__
 179                      -> CharBuffer -> [String]
 180                      -> IO String
 181 hGetLineBufferedLoop handle_@Handle__{..}
 182         buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =
 183   let
 184         -- find the end-of-line character, if there is one
 185         loop raw r
 186            | r == w = return (False, w)
 187            | otherwise =  do
 188                 (c,r') <- readCharBuf raw r
 189                 if c == '\n'
 190                    then return (True, r) -- NB. not r': don't include the '\n'
 191                    else loop raw r'
 192   in do
 193   (eol, off) <- loop raw0 r0
 194
 195   debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)
 196
 197   (xs,r') <- if haInputNL == CRLF
 198                 then unpack_nl raw0 r0 off ""
 199                 else do xs <- unpack raw0 r0 off ""
 200                         return (xs,off)
 201
 202   -- if eol == True, then off is the offset of the '\n'
 203   -- otherwise off == w and the buffer is now empty.
 204   if eol -- r' == off
 205         then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
 206                 return (concat (reverse (xs:xss)))
 207         else do
 208              let buf1 = bufferAdjustL r' buf
 209              maybe_buf <- maybeFillReadBuffer handle_ buf1
 210              case maybe_buf of
 211                 -- Nothing indicates we caught an EOF, and we may have a
 212                 -- partial line to return.
 213                 Nothing -> do
 214                      -- we reached EOF.  There might be a lone \r left
 215                      -- in the buffer, so check for that and
 216                      -- append it to the line if necessary.
 217                      --
 218                      let pre = if not (isEmptyBuffer buf1) then "\r" else ""
 219                      writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
 220                      let str = concat (reverse (pre:xs:xss))
 221                      if not (null str)
 222                         then return str
 223                         else ioe_EOF
 224                 Just new_buf ->
 225                      hGetLineBufferedLoop handle_ new_buf (xs:xss)
 226
 227 maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
 228 maybeFillReadBuffer handle_ buf
 229   = catch
 230      (do buf' <- getSomeCharacters handle_ buf
 231          return (Just buf')
 232      )
 233      (\e -> do if isEOFError e
 234                   then return Nothing
 235                   else ioError e)
 236
 237 -- See GHC.IO.Buffer
 238 #define CHARBUF_UTF32
 239 -- #define CHARBUF_UTF16
 240
 241 -- NB. performance-critical code: eyeball the Core.
 242 unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char]
 243 unpack !buf !r !w acc0
 244  | r == w    = return acc0
 245  | otherwise =
 246   withRawBuffer buf $ \pbuf ->
 247     let
 248         unpackRB acc !i
 249          | i < r  = return acc
 250          | otherwise = do
 251 #ifdef CHARBUF_UTF16
 252               -- reverse-order decoding of UTF-16
 253               c2 <- peekElemOff pbuf i
 254               if (c2 < 0xdc00 || c2 > 0xdffff)
 255                  then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1)
 256                  else do c1 <- peekElemOff pbuf (i-1)
 257                          let c = (fromIntegral c1 - 0xd800) * 0x400 +
 258                                  (fromIntegral c2 - 0xdc00) + 0x10000
 259                          unpackRB (unsafeChr c : acc) (i-2)
 260 #else
 261               c <- peekElemOff pbuf i
 262               unpackRB (c:acc) (i-1)
 263 #endif
 264      in
 265      unpackRB acc0 (w-1)
 266
 267 -- NB. performance-critical code: eyeball the Core.
 268 unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int)
 269 unpack_nl !buf !r !w acc0
 270  | r == w    =  return (acc0, 0)
 271  | otherwise =
 272   withRawBuffer buf $ \pbuf ->
 273     let
 274         unpackRB acc !i
 275          | i < r  = return acc
 276          | otherwise = do
 277               c <- peekElemOff pbuf i
 278               if (c == '\n' && i > r)
 279                  then do
 280                          c1 <- peekElemOff pbuf (i-1)
 281                          if (c1 == '\r')
 282                             then unpackRB ('\n':acc) (i-2)
 283                             else unpackRB ('\n':acc) (i-1)
 284                  else do
 285                          unpackRB (c:acc) (i-1)
 286      in do
 287      c <- peekElemOff pbuf (w-1)
 288      if (c == '\r')
 289         then do
 290                 -- If the last char is a '\r', we need to know whether or
 291                 -- not it is followed by a '\n', so leave it in the buffer
 292                 -- for now and just unpack the rest.
 293                 str <- unpackRB acc0 (w-2)
 294                 return (str, w-1)
 295         else do
 296                 str <- unpackRB acc0 (w-1)
 297                 return (str, w)
 298
 299
 300 -- -----------------------------------------------------------------------------
 301 -- hGetContents
 302
 303 -- hGetContents on a DuplexHandle only affects the read side: you can
 304 -- carry on writing to it afterwards.
 305
 306 -- | Computation 'hGetContents' @hdl@ returns the list of characters
 307 -- corresponding to the unread portion of the channel or file managed
 308 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
 309 -- In this state, @hdl@ is effectively closed,
 310 -- but items are read from @hdl@ on demand and accumulated in a special
 311 -- list returned by 'hGetContents' @hdl@.
 312 --
 313 -- Any operation that fails because a handle is closed,
 314 -- also fails if a handle is semi-closed.  The only exception is 'hClose'.
 315 -- A semi-closed handle becomes closed:
 316 --
 317 --  * if 'hClose' is applied to it;
 318 --
 319 --  * if an I\/O error occurs when reading an item from the handle;
 320 --
 321 --  * or once the entire contents of the handle has been read.
 322 --
 323 -- Once a semi-closed handle becomes closed, the contents of the
 324 -- associated list becomes fixed.  The contents of this final list is
 325 -- only partially specified: it will contain at least all the items of
 326 -- the stream that were evaluated prior to the handle becoming closed.
 327 --
 328 -- Any I\/O errors encountered while a handle is semi-closed are simply
 329 -- discarded.
 330 --
 331 -- This operation may fail with:
 332 --
 333 --  * 'isEOFError' if the end of file has been reached.
 334
 335 hGetContents :: Handle -> IO String
 336 hGetContents handle =
 337    wantReadableHandle "hGetContents" handle $ \handle_ -> do
 338       xs <- lazyRead handle
 339       return (handle_{ haType=SemiClosedHandle}, xs )
 340
 341 -- Note that someone may close the semi-closed handle (or change its
 342 -- buffering), so each time these lazy read functions are pulled on,
 343 -- they have to check whether the handle has indeed been closed.
 344
 345 lazyRead :: Handle -> IO String
 346 lazyRead handle =
 347    unsafeInterleaveIO $
 348         withHandle "lazyRead" handle $ \ handle_ -> do
 349         case haType handle_ of
 350           ClosedHandle     -> return (handle_, "")
 351           SemiClosedHandle -> lazyReadBuffered handle handle_
 352           _ -> ioException
 353                   (IOError (Just handle) IllegalOperation "lazyRead"
 354                         "illegal handle type" Nothing Nothing)
 355
 356 lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
 357 lazyReadBuffered h handle_@Handle__{..} = do
 358    buf <- readIORef haCharBuffer
 359    catch
 360         (do
 361             buf'@Buffer{..} <- getSomeCharacters handle_ buf
 362             lazy_rest <- lazyRead h
 363             (s,r) <- if haInputNL == CRLF
 364                          then unpack_nl bufRaw bufL bufR lazy_rest
 365                          else do s <- unpack bufRaw bufL bufR lazy_rest
 366                                  return (s,bufR)
 367             writeIORef haCharBuffer (bufferAdjustL r buf')
 368             return (handle_, s)
 369         )
 370         -- all I/O errors are discarded.  Additionally, we close the handle.
 371         (\e -> do (handle_', _) <- hClose_help handle_
 372                   debugIO ("hGetContents caught: " ++ show e)
 373                   -- We might have a \r cached in CRLF mode.  So we
 374                   -- need to check for that and return it:
 375                   if not (isEmptyBuffer buf)
 376                      then return (handle_', "\r")
 377                      else return (handle_', "")
 378         )
 379
 380 -- ensure we have some characters in the buffer
 381 getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
 382 getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
 383   case bufferElems buf of
 384
 385     -- buffer empty: read some more
 386     0 -> readTextDevice handle_ buf
 387
 388     -- if the buffer has a single '\r' in it and we're doing newline
 389     -- translation: read some more
 390     1 | haInputNL == CRLF -> do
 391       (c,_) <- readCharBuf bufRaw bufL
 392       if c == '\r'
 393          then do -- shuffle the '\r' to the beginning.  This is only safe
 394                  -- if we're about to call readTextDevice, otherwise it
 395                  -- would mess up flushCharBuffer.
 396                  -- See [note Buffer Flushing], GHC.IO.Handle.Types
 397                  writeCharBuf bufRaw 0 '\r'
 398                  let buf' = buf{ bufL=0, bufR=1 }
 399                  readTextDevice handle_ buf'
 400          else do
 401                  return buf
 402
 403     -- buffer has some chars in it already: just return it
 404     _otherwise ->
 405       return buf
 406
 407 -- ---------------------------------------------------------------------------
 408 -- hPutChar
 409
 410 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
 411 -- file or channel managed by @hdl@.  Characters may be buffered if
 412 -- buffering is enabled for @hdl@.
 413 --
 414 -- This operation may fail with:
 415 --
 416 --  * 'isFullError' if the device is full; or
 417 --
 418 --  * 'isPermissionError' if another system resource limit would be exceeded.
 419
 420 hPutChar :: Handle -> Char -> IO ()
 421 hPutChar handle c = do
 422     c `seq` return ()
 423     wantWritableHandle "hPutChar" handle $ \ handle_  -> do
 424     case haBufferMode handle_ of
 425         LineBuffering -> hPutcBuffered handle_ True  c
 426         _other        -> hPutcBuffered handle_ False c
 427
 428 hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
 429 hPutcBuffered handle_@Handle__{..} is_line c = do
 430   buf <- readIORef haCharBuffer
 431   if c == '\n'
 432      then do buf1 <- if haOutputNL == CRLF
 433                         then do
 434                           buf1 <- putc buf '\r'
 435                           putc buf1 '\n'
 436                         else do
 437                           putc buf '\n'
 438              if is_line
 439                 then do
 440                   flushed_buf <- flushWriteBuffer_ handle_ buf1
 441                   writeIORef haCharBuffer flushed_buf
 442                 else
 443                   writeIORef haCharBuffer buf1
 444       else do
 445           buf1 <- putc buf c
 446           writeIORef haCharBuffer buf1
 447   where
 448     putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
 449        debugIO ("putc: " ++ summaryBuffer buf)
 450        w'  <- writeCharBuf raw w c
 451        let buf' = buf{ bufR = w' }
 452        if isFullCharBuffer buf'
 453           then flushWriteBuffer_ handle_ buf'
 454           else return buf'
 455
 456 -- ---------------------------------------------------------------------------
 457 -- hPutStr
 458
 459 -- We go to some trouble to avoid keeping the handle locked while we're
 460 -- evaluating the string argument to hPutStr, in case doing so triggers another
 461 -- I/O operation on the same handle which would lead to deadlock.  The classic
 462 -- case is
 463 --
 464 --              putStr (trace "hello" "world")
 465 --
 466 -- so the basic scheme is this:
 467 --
 468 --      * copy the string into a fresh buffer,
 469 --      * "commit" the buffer to the handle.
 470 --
 471 -- Committing may involve simply copying the contents of the new
 472 -- buffer into the handle's buffer, flushing one or both buffers, or
 473 -- maybe just swapping the buffers over (if the handle's buffer was
 474 -- empty).  See commitBuffer below.
 475
 476 -- | Computation 'hPutStr' @hdl s@ writes the string
 477 -- @s@ to the file or channel managed by @hdl@.
 478 --
 479 -- This operation may fail with:
 480 --
 481 --  * 'isFullError' if the device is full; or
 482 --
 483 --  * 'isPermissionError' if another system resource limit would be exceeded.
 484
 485 hPutStr :: Handle -> String -> IO ()
 486 hPutStr handle str = do
 487     (buffer_mode, nl) <-
 488          wantWritableHandle "hPutStr" handle $ \h_ -> do
 489                        bmode <- getSpareBuffer h_
 490                        return (bmode, haOutputNL h_)
 491
 492     case buffer_mode of
 493        (NoBuffering, _) -> do
 494             hPutChars handle str        -- v. slow, but we don't care
 495        (LineBuffering, buf) -> do
 496             writeBlocks handle True  nl buf str
 497        (BlockBuffering _, buf) -> do
 498             writeBlocks handle False nl buf str
 499
 500 hPutChars :: Handle -> [Char] -> IO ()
 501 hPutChars _      [] = return ()
 502 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
 503
 504 getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
 505 getSpareBuffer Handle__{haCharBuffer=ref,
 506                         haBuffers=spare_ref,
 507                         haBufferMode=mode}
 508  = do
 509    case mode of
 510      NoBuffering -> return (mode, error "no buffer!")
 511      _ -> do
 512           bufs <- readIORef spare_ref
 513           buf  <- readIORef ref
 514           case bufs of
 515             BufferListCons b rest -> do
 516                 writeIORef spare_ref rest
 517                 return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
 518             BufferListNil -> do
 519                 new_buf <- newCharBuffer (bufSize buf) WriteBuffer
 520                 return (mode, new_buf)
 521
 522
 523 -- NB. performance-critical code: eyeball the Core.
 524 writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
 525 writeBlocks hdl line_buffered nl
 526             buf@Buffer{ bufRaw=raw, bufSize=len } s =
 527   let
 528    shoveString :: Int -> [Char] -> IO ()
 529    shoveString !n [] = do
 530         commitBuffer hdl raw len n False{-no flush-} True{-release-}
 531         return ()
 532    shoveString !n (c:cs)
 533      -- n+1 so we have enough room to write '\r\n' if necessary
 534      | n + 1 >= len = do
 535         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 536         writeBlocks hdl line_buffered nl new_buf (c:cs)
 537      | c == '\n'  =  do
 538         n' <- if nl == CRLF
 539                  then do
 540                     n1 <- writeCharBuf raw n  '\r'
 541                     writeCharBuf raw n1 '\n'
 542                  else do
 543                     writeCharBuf raw n c
 544         if line_buffered
 545            then do
 546                new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
 547                writeBlocks hdl line_buffered nl new_buf cs
 548            else do
 549                shoveString n' cs
 550      | otherwise = do
 551         n' <- writeCharBuf raw n c
 552         shoveString n' cs
 553   in
 554   shoveString 0 s
 555
 556 -- -----------------------------------------------------------------------------
 557 -- commitBuffer handle buf sz count flush release
 558 --
 559 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
 560 -- 'count' bytes of data) to handle (handle must be block or line buffered).
 561 --
 562 -- Implementation:
 563 --
 564 --    for block/line buffering,
 565 --       1. If there isn't room in the handle buffer, flush the handle
 566 --          buffer.
 567 --
 568 --       2. If the handle buffer is empty,
 569 --               if flush,
 570 --                   then write buf directly to the device.
 571 --                   else swap the handle buffer with buf.
 572 --
 573 --       3. If the handle buffer is non-empty, copy buf into the
 574 --          handle buffer.  Then, if flush != 0, flush
 575 --          the buffer.
 576
 577 commitBuffer
 578         :: Handle                       -- handle to commit to
 579         -> RawCharBuffer -> Int         -- address and size (in bytes) of buffer
 580         -> Int                          -- number of bytes of data in buffer
 581         -> Bool                         -- True <=> flush the handle afterward
 582         -> Bool                         -- release the buffer?
 583         -> IO CharBuffer
 584
 585 commitBuffer hdl !raw !sz !count flush release =
 586   wantWritableHandle "commitAndReleaseBuffer" hdl $
 587      commitBuffer' raw sz count flush release
 588 {-# NOINLINE commitBuffer #-}
 589
 590 -- Explicitly lambda-lift this function to subvert GHC's full laziness
 591 -- optimisations, which otherwise tends to float out subexpressions
 592 -- past the \handle, which is really a pessimisation in this case because
 593 -- that lambda is a one-shot lambda.
 594 --
 595 -- Don't forget to export the function, to stop it being inlined too
 596 -- (this appears to be better than NOINLINE, because the strictness
 597 -- analyser still gets to worker-wrapper it).
 598 --
 599 -- This hack is a fairly big win for hPutStr performance.  --SDM 18/9/2001
 600 --
 601 commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
 602               -> IO CharBuffer
 603 commitBuffer' raw sz@(I# _) count@(I# _) flush release
 604   handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do
 605
 606       debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
 607             ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
 608
 609       old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
 610           <- readIORef ref
 611
 612       buf_ret <-
 613         -- enough room in handle buffer?
 614          if (not flush && (size - w > count))
 615                 -- The > is to be sure that we never exactly fill
 616                 -- up the buffer, which would require a flush.  So
 617                 -- if copying the new data into the buffer would
 618                 -- make the buffer full, we just flush the existing
 619                 -- buffer and the new data immediately, rather than
 620                 -- copying before flushing.
 621
 622                 -- not flushing, and there's enough room in the buffer:
 623                 -- just copy the data in and update bufR.
 624             then do withRawBuffer raw     $ \praw ->
 625                       copyToRawBuffer old_raw (w*charSize)
 626                                       praw (fromIntegral (count*charSize))
 627                     writeIORef ref old_buf{ bufR = w + count }
 628                     return (emptyBuffer raw sz WriteBuffer)
 629
 630                 -- else, we have to flush
 631             else do flushed_buf <- flushWriteBuffer_ handle_ old_buf
 632
 633                     let this_buf =
 634                             Buffer{ bufRaw=raw, bufState=WriteBuffer,
 635                                     bufL=0, bufR=count, bufSize=sz }
 636
 637                         -- if:  (a) we don't have to flush, and
 638                         --      (b) size(new buffer) == size(old buffer), and
 639                         --      (c) new buffer is not full,
 640                         -- we can just just swap them over...
 641                     if (not flush && sz == size && count /= sz)
 642                         then do
 643                           writeIORef ref this_buf
 644                           return flushed_buf
 645
 646                         -- otherwise, we have to flush the new data too,
 647                         -- and start with a fresh buffer
 648                         else do
 649                           flushWriteBuffer_ handle_ this_buf
 650                           writeIORef ref flushed_buf
 651                             -- if the sizes were different, then allocate
 652                             -- a new buffer of the correct size.
 653                           if sz == size
 654                              then return (emptyBuffer raw sz WriteBuffer)
 655                              else newCharBuffer size WriteBuffer
 656
 657       -- release the buffer if necessary
 658       case buf_ret of
 659         Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do
 660           if release && buf_ret_sz == size
 661             then do
 662               spare_bufs <- readIORef spare_buf_ref
 663               writeIORef spare_buf_ref
 664                 (BufferListCons buf_ret_raw spare_bufs)
 665               return buf_ret
 666             else
 667               return buf_ret
 668
 669 -- ---------------------------------------------------------------------------
 670 -- Reading/writing sequences of bytes.
 671
 672 -- ---------------------------------------------------------------------------
 673 -- hPutBuf
 674
 675 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
 676 -- buffer @buf@ to the handle @hdl@.  It returns ().
 677 --
 678 -- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
 679 -- writing the bytes directly to the underlying file or device.
 680 --
 681 -- This operation may fail with:
 682 --
 683 --  * 'ResourceVanished' if the handle is a pipe or socket, and the
 684 --    reading end is closed.  (If this is a POSIX system, and the program
 685 --    has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
 686 --    instead, whose default action is to terminate the program).
 687
 688 hPutBuf :: Handle                       -- handle to write to
 689         -> Ptr a                        -- address of buffer
 690         -> Int                          -- number of bytes of data in buffer
 691         -> IO ()
 692 hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
 693
 694 hPutBufNonBlocking
 695         :: Handle                       -- handle to write to
 696         -> Ptr a                        -- address of buffer
 697         -> Int                          -- number of bytes of data in buffer
 698         -> IO Int                       -- returns: number of bytes written
 699 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
 700
 701 hPutBuf':: Handle                       -- handle to write to
 702         -> Ptr a                        -- address of buffer
 703         -> Int                          -- number of bytes of data in buffer
 704         -> Bool                         -- allow blocking?
 705         -> IO Int
 706 hPutBuf' handle ptr count can_block
 707   | count == 0 = return 0
 708   | count <  0 = illegalBufferSize handle "hPutBuf" count
 709   | otherwise =
 710     wantWritableHandle "hPutBuf" handle $
 711       \ h_@Handle__{..} -> do
 712           debugIO ("hPutBuf count=" ++ show count)
 713           -- first flush the Char buffer if it is non-empty, then we
 714           -- can work directly with the byte buffer
 715           cbuf <- readIORef haCharBuffer
 716           when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_
 717
 718           r <- bufWrite h_ (castPtr ptr) count can_block
 719
 720           -- we must flush if this Handle is set to NoBuffering.  If
 721           -- it is set to LineBuffering, be conservative and flush
 722           -- anyway (we didn't check for newlines in the data).
 723           case haBufferMode of
 724              BlockBuffering _      -> do return ()
 725              _line_or_no_buffering -> do flushWriteBuffer h_
 726           return r
 727
 728 bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
 729 bufWrite h_@Handle__{..} ptr count can_block =
 730   seq count $ do  -- strictness hack
 731   old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
 732      <- readIORef haByteBuffer
 733
 734   -- enough room in handle buffer?
 735   if (size - w > count)
 736         -- There's enough room in the buffer:
 737         -- just copy the data in and update bufR.
 738         then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
 739                 copyToRawBuffer old_raw w ptr (fromIntegral count)
 740                 writeIORef haByteBuffer old_buf{ bufR = w + count }
 741                 return count
 742
 743         -- else, we have to flush
 744         else do debugIO "hPutBuf: flushing first"
 745                 Buffered.flushWriteBuffer haDevice old_buf
 746                         -- TODO: we should do a non-blocking flush here
 747                 writeIORef haByteBuffer old_buf{bufL=0,bufR=0}
 748                 -- if we can fit in the buffer, then just loop
 749                 if count < size
 750                    then bufWrite h_ ptr count can_block
 751                    else if can_block
 752                            then do writeChunk h_ (castPtr ptr) count
 753                                    return count
 754                            else writeChunkNonBlocking h_ (castPtr ptr) count
 755
 756 writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
 757 writeChunk h_@Handle__{..} ptr bytes
 758   | Just fd <- cast haDevice  =  RawIO.write (fd::FD) ptr bytes
 759   | otherwise = error "Todo: hPutBuf"
 760
 761 writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
 762 writeChunkNonBlocking h_@Handle__{..} ptr bytes
 763   | Just fd <- cast haDevice  =  RawIO.writeNonBlocking (fd::FD) ptr bytes
 764   | otherwise = error "Todo: hPutBuf"
 765
 766 -- ---------------------------------------------------------------------------
 767 -- hGetBuf
 768
 769 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
 770 -- into the buffer @buf@ until either EOF is reached or
 771 -- @count@ 8-bit bytes have been read.
 772 -- It returns the number of bytes actually read.  This may be zero if
 773 -- EOF was reached before any data was read (or if @count@ is zero).
 774 --
 775 -- 'hGetBuf' ignores whatever 'TextEncoding' the 'Handle' is currently
 776 -- using, and reads bytes directly from the underlying IO device.
 777 --
 778 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
 779 -- smaller than @count@.
 780 --
 781 -- If the handle is a pipe or socket, and the writing end
 782 -- is closed, 'hGetBuf' will behave as if EOF was reached.
 783 --
 784
 785 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
 786 hGetBuf h ptr count
 787   | count == 0 = return 0
 788   | count <  0 = illegalBufferSize h "hGetBuf" count
 789   | otherwise =
 790       wantReadableHandle_ "hGetBuf" h $ \ h_ -> do
 791          flushCharReadBuffer h_
 792          bufRead h_ (castPtr ptr) 0 count
 793
 794 -- small reads go through the buffer, large reads are satisfied by
 795 -- taking data first from the buffer and then direct from the file
 796 -- descriptor.
 797 bufRead :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
 798 bufRead h_@Handle__{..} ptr so_far count =
 799   seq so_far $ seq count $ do -- strictness hack
 800   buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
 801   if isEmptyBuffer buf
 802      then if count > sz  -- small read?
 803                 then do rest <- readChunk h_ ptr count
 804                         return (so_far + rest)
 805                 else do (r,buf') <- Buffered.fillReadBuffer haDevice buf
 806                         if r == 0
 807                            then return so_far
 808                            else do writeIORef haByteBuffer buf'
 809                                    bufRead h_ ptr so_far count
 810      else do
 811         let avail = w - r
 812         if (count == avail)
 813            then do
 814                 copyFromRawBuffer ptr raw r count
 815                 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
 816                 return (so_far + count)
 817            else do
 818         if (count < avail)
 819            then do
 820                 copyFromRawBuffer ptr raw r count
 821                 writeIORef haByteBuffer buf{ bufL = r + count }
 822                 return (so_far + count)
 823            else do
 824
 825         copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
 826         writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
 827         let remaining = count - avail
 828             so_far' = so_far + avail
 829             ptr' = ptr `plusPtr` avail
 830
 831         if remaining < sz
 832            then bufRead h_ ptr' so_far' remaining
 833            else do
 834
 835         rest <- readChunk h_ ptr' remaining
 836         return (so_far' + rest)
 837
 838 readChunk :: Handle__ -> Ptr a -> Int -> IO Int
 839 readChunk h_@Handle__{..} ptr bytes
 840  | Just fd <- cast haDevice = loop fd 0 bytes
 841  | otherwise = error "ToDo: hGetBuf"
 842  where
 843   loop :: FD -> Int -> Int -> IO Int
 844   loop fd off bytes | bytes <= 0 = return off
 845   loop fd off bytes = do
 846     r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes)
 847     if r == 0
 848         then return off
 849         else loop fd (off + r) (bytes - r)
 850
 851 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
 852 -- into the buffer @buf@ until either EOF is reached, or
 853 -- @count@ 8-bit bytes have been read, or there is no more data available
 854 -- to read immediately.
 855 --
 856 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
 857 -- never block waiting for data to become available, instead it returns
 858 -- only whatever data is available.  To wait for data to arrive before
 859 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
 860 --
 861 -- 'hGetBufNonBlocking' ignores whatever 'TextEncoding' the 'Handle'
 862 -- is currently using, and reads bytes directly from the underlying IO
 863 -- device.
 864 --
 865 -- If the handle is a pipe or socket, and the writing end
 866 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
 867 --
 868 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
 869 hGetBufNonBlocking h ptr count
 870   | count == 0 = return 0
 871   | count <  0 = illegalBufferSize h "hGetBufNonBlocking" count
 872   | otherwise =
 873       wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do
 874          flushCharReadBuffer h_
 875          bufReadNonBlocking h_ (castPtr ptr) 0 count
 876
 877 bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
 878 bufReadNonBlocking h_@Handle__{..} ptr so_far count =
 879   seq so_far $ seq count $ do -- strictness hack
 880   buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
 881   if isEmptyBuffer buf
 882      then if count > sz  -- large read?
 883                 then do rest <- readChunkNonBlocking h_ ptr count
 884                         return (so_far + rest)
 885                 else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
 886                         case r of
 887                           Nothing -> return so_far
 888                           Just 0  -> return so_far
 889                           Just r  -> do
 890                             writeIORef haByteBuffer buf'
 891                             bufReadNonBlocking h_ ptr so_far (min count r)
 892                                   -- NOTE: new count is    min count w'
 893                                   -- so we will just copy the contents of the
 894                                   -- buffer in the recursive call, and not
 895                                   -- loop again.
 896      else do
 897         let avail = w - r
 898         if (count == avail)
 899            then do
 900                 copyFromRawBuffer ptr raw r count
 901                 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
 902                 return (so_far + count)
 903            else do
 904         if (count < avail)
 905            then do
 906                 copyFromRawBuffer ptr raw r count
 907                 writeIORef haByteBuffer buf{ bufL = r + count }
 908                 return (so_far + count)
 909            else do
 910
 911         copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
 912         writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
 913         let remaining = count - avail
 914             so_far' = so_far + avail
 915             ptr' = ptr `plusPtr` avail
 916
 917         -- we haven't attempted to read anything yet if we get to here.
 918         if remaining < sz
 919            then bufReadNonBlocking h_ ptr' so_far' remaining
 920            else do
 921
 922         rest <- readChunkNonBlocking h_ ptr' remaining
 923         return (so_far' + rest)
 924
 925
 926 readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
 927 readChunkNonBlocking h_@Handle__{..} ptr bytes
 928  | Just fd <- cast haDevice = do
 929      m <- RawIO.readNonBlocking (fd::FD) ptr bytes
 930      case m of
 931        Nothing -> return 0
 932        Just n  -> return n
 933  | otherwise = error "ToDo: hGetBuf"
 934
 935 -- ---------------------------------------------------------------------------
 936 -- memcpy wrappers
 937
 938 copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
 939 copyToRawBuffer raw off ptr bytes = do
 940  withRawBuffer raw $ \praw ->
 941    memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
 942  return ()
 943
 944 copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
 945 copyFromRawBuffer ptr raw off bytes = do
 946  withRawBuffer raw $ \praw ->
 947    memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
 948  return ()
 949
 950 foreign import ccall unsafe "memcpy"
 951    memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
 952
 953 -----------------------------------------------------------------------------
 954 -- Internal Utils
 955
 956 illegalBufferSize :: Handle -> String -> Int -> IO a
 957 illegalBufferSize handle fn sz =
 958         ioException (IOError (Just handle)
 959                             InvalidArgument  fn
 960                             ("illegal buffer size " ++ showsPrec 9 sz [])
 961                             Nothing Nothing)