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