Text.hs 38.6 KB
Newer Older
1
{-# LANGUAGE Trustworthy #-}
2
3
4
5
6
7
8
{-# LANGUAGE CPP
           , NoImplicitPrelude
           , RecordWildCards
           , BangPatterns
           , NondecreasingIndentation
           , MagicHash
  #-}
9
10
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
11
12
13
14
15
16
17
{-# OPTIONS_HADDOCK hide #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.Text
-- Copyright   :  (c) The University of Glasgow, 1992-2008
-- License     :  see libraries/base/LICENSE
18
--
19
20
21
22
23
24
25
26
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- String I\/O functions
--
-----------------------------------------------------------------------------

27
module GHC.IO.Handle.Text (
28
29
30
31
32
        hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
        commitBuffer',       -- hack, see below
        hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
        memcpy, hPutStrLn,
    ) where
33
34
35
36
37
38

import GHC.IO
import GHC.IO.FD
import GHC.IO.Buffer
import qualified GHC.IO.BufferedIO as Buffered
import GHC.IO.Exception
39
import GHC.Exception
40
41
42
43
44
45
46
47
import GHC.IO.Handle.Types
import GHC.IO.Handle.Internals
import qualified GHC.IO.Device as IODevice
import qualified GHC.IO.Device as RawIO

import Foreign
import Foreign.C

48
import qualified Control.Exception as Exception
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
import Data.Typeable
import System.IO.Error
import Data.Maybe

import GHC.IORef
import GHC.Base
import GHC.Real
import GHC.Num
import GHC.Show
import GHC.List

-- ---------------------------------------------------------------------------
-- Simple input operations

-- If hWaitForInput finds anything in the Handle's buffer, it
-- immediately returns.  If not, it tries to read from the underlying
-- OS handle. Notice that for buffered Handles connected to terminals
-- this means waiting until a complete line is available.

-- | Computation 'hWaitForInput' @hdl t@
-- waits until input is available on handle @hdl@.
-- It returns 'True' as soon as input is available on @hdl@,
71
72
73
74
-- or 'False' if no input is available within @t@ milliseconds.  Note that
-- 'hWaitForInput' waits until one or more full /characters/ are available,
-- which means that it needs to do decoding, and hence may fail
-- with a decoding error.
75
76
77
78
79
80
--
-- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
--
-- This operation may fail with:
--
--  * 'isEOFError' if the end of file has been reached.
Simon Marlow's avatar
Simon Marlow committed
81
--
82
83
--  * a decoding error, if the input begins with an invalid byte sequence
--    in this Handle's encoding.
84
85
--
-- NOTE for GHC users: unless you use the @-threaded@ flag,
ian@well-typed.com's avatar
ian@well-typed.com committed
86
-- @hWaitForInput hdl t@ where @t >= 0@ will block all other Haskell
87
88
-- threads for the duration of the call.  It behaves like a
-- @safe@ foreign call in this respect.
89
--
90
91
92
93

hWaitForInput :: Handle -> Int -> IO Bool
hWaitForInput h msecs = do
  wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do
Simon Marlow's avatar
Simon Marlow committed
94
  cbuf <- readIORef haCharBuffer
95

Simon Marlow's avatar
Simon Marlow committed
96
  if not (isEmptyBuffer cbuf) then return True else do
97

98
  if msecs < 0
Simon Marlow's avatar
Simon Marlow committed
99
100
        then do cbuf' <- readTextDevice handle_ cbuf
                writeIORef haCharBuffer cbuf'
101
                return True
Simon Marlow's avatar
Simon Marlow committed
102
103
        else do
               -- there might be bytes in the byte buffer waiting to be decoded
104
               cbuf' <- decodeByteBuf handle_ cbuf
Simon Marlow's avatar
Simon Marlow committed
105
106
107
108
109
               writeIORef haCharBuffer cbuf'

               if not (isEmptyBuffer cbuf') then return True else do

                r <- IODevice.ready haDevice False{-read-} msecs
110
                if r then do -- Call hLookAhead' to throw an EOF
111
112
113
114
                             -- exception if appropriate
                             _ <- hLookAhead_ handle_
                             return True
                     else return False
Simon Marlow's avatar
Simon Marlow committed
115
116
117
118
119
                -- XXX we should only return when there are full characters
                -- not when there are only bytes.  That would mean looping
                -- and re-running IODevice.ready if we don't have any full
                -- characters; but we don't know how long we've waited
                -- so far.
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236

-- ---------------------------------------------------------------------------
-- hGetChar

-- | Computation 'hGetChar' @hdl@ reads a character from the file or
-- channel managed by @hdl@, blocking until a character is available.
--
-- This operation may fail with:
--
--  * 'isEOFError' if the end of file has been reached.

hGetChar :: Handle -> IO Char
hGetChar handle =
  wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do

  -- buffering mode makes no difference: we just read whatever is available
  -- from the device (blocking only if there is nothing available), and then
  -- return the first character.
  -- See [note Buffered Reading] in GHC.IO.Handle.Types
  buf0 <- readIORef haCharBuffer

  buf1 <- if isEmptyBuffer buf0
             then readTextDevice handle_ buf0
             else return buf0

  (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)
  let buf2 = bufferAdjustL i buf1

  if haInputNL == CRLF && c1 == '\r'
     then do
            mbuf3 <- if isEmptyBuffer buf2
                      then maybeFillReadBuffer handle_ buf2
                      else return (Just buf2)

            case mbuf3 of
               -- EOF, so just return the '\r' we have
               Nothing -> do
                  writeIORef haCharBuffer buf2
                  return '\r'
               Just buf3 -> do
                  (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)
                  if c2 == '\n'
                     then do
                       writeIORef haCharBuffer (bufferAdjustL i2 buf3)
                       return '\n'
                     else do
                       -- not a \r\n sequence, so just return the \r
                       writeIORef haCharBuffer buf3
                       return '\r'
     else do
            writeIORef haCharBuffer buf2
            return c1

-- ---------------------------------------------------------------------------
-- hGetLine

-- | Computation 'hGetLine' @hdl@ reads a line from the file or
-- channel managed by @hdl@.
--
-- This operation may fail with:
--
--  * 'isEOFError' if the end of file is encountered when reading
--    the /first/ character of the line.
--
-- If 'hGetLine' encounters end-of-file at any other point while reading
-- in a line, it is treated as a line terminator and the (partial)
-- line is returned.

hGetLine :: Handle -> IO String
hGetLine h =
  wantReadableHandle_ "hGetLine" h $ \ handle_ -> do
     hGetLineBuffered handle_

hGetLineBuffered :: Handle__ -> IO String
hGetLineBuffered handle_@Handle__{..} = do
  buf <- readIORef haCharBuffer
  hGetLineBufferedLoop handle_ buf []

hGetLineBufferedLoop :: Handle__
                     -> CharBuffer -> [String]
                     -> IO String
hGetLineBufferedLoop handle_@Handle__{..}
        buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =
  let
        -- find the end-of-line character, if there is one
        loop raw r
           | r == w = return (False, w)
           | otherwise =  do
                (c,r') <- readCharBuf raw r
                if c == '\n'
                   then return (True, r) -- NB. not r': don't include the '\n'
                   else loop raw r'
  in do
  (eol, off) <- loop raw0 r0

  debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)

  (xs,r') <- if haInputNL == CRLF
                then unpack_nl raw0 r0 off ""
                else do xs <- unpack raw0 r0 off ""
                        return (xs,off)

  -- if eol == True, then off is the offset of the '\n'
  -- otherwise off == w and the buffer is now empty.
  if eol -- r' == off
        then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
                return (concat (reverse (xs:xss)))
        else do
             let buf1 = bufferAdjustL r' buf
             maybe_buf <- maybeFillReadBuffer handle_ buf1
             case maybe_buf of
                -- Nothing indicates we caught an EOF, and we may have a
                -- partial line to return.
                Nothing -> do
                     -- we reached EOF.  There might be a lone \r left
                     -- in the buffer, so check for that and
                     -- append it to the line if necessary.
237
                     --
238
239
240
241
242
243
244
245
246
247
248
                     let pre = if not (isEmptyBuffer buf1) then "\r" else ""
                     writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
                     let str = concat (reverse (pre:xs:xss))
                     if not (null str)
                        then return str
                        else ioe_EOF
                Just new_buf ->
                     hGetLineBufferedLoop handle_ new_buf (xs:xss)

maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
maybeFillReadBuffer handle_ buf
249
  = catchException
250
251
252
     (do buf' <- getSomeCharacters handle_ buf
         return (Just buf')
     )
253
254
     (\e -> do if isEOFError e
                  then return Nothing
255
256
257
258
259
260
261
262
263
264
                  else ioError e)

-- See GHC.IO.Buffer
#define CHARBUF_UTF32
-- #define CHARBUF_UTF16

-- NB. performance-critical code: eyeball the Core.
unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char]
unpack !buf !r !w acc0
 | r == w    = return acc0
265
266
 | otherwise =
  withRawBuffer buf $ \pbuf ->
267
268
269
270
    let
        unpackRB acc !i
         | i < r  = return acc
         | otherwise = do
271
272
              -- Here, we are rather careful to only put an *evaluated* character
              -- in the output string. Due to pointer tagging, this allows the consumer
273
              -- to avoid ping-ponging between the actual consumer code and the thunk code
Ben Gamari's avatar
Ben Gamari committed
274
#if defined(CHARBUF_UTF16)
275
276
277
278
279
280
281
              -- reverse-order decoding of UTF-16
              c2 <- peekElemOff pbuf i
              if (c2 < 0xdc00 || c2 > 0xdffff)
                 then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1)
                 else do c1 <- peekElemOff pbuf (i-1)
                         let c = (fromIntegral c1 - 0xd800) * 0x400 +
                                 (fromIntegral c2 - 0xdc00) + 0x10000
282
283
                         case desurrogatifyRoundtripCharacter (unsafeChr c) of
                           { C# c# -> unpackRB (C# c# : acc) (i-2) }
284
285
#else
              c <- peekElemOff pbuf i
286
              unpackRB (c : acc) (i-1)
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
#endif
     in
     unpackRB acc0 (w-1)

-- NB. performance-critical code: eyeball the Core.
unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int)
unpack_nl !buf !r !w acc0
 | r == w    =  return (acc0, 0)
 | otherwise =
  withRawBuffer buf $ \pbuf ->
    let
        unpackRB acc !i
         | i < r  = return acc
         | otherwise = do
              c <- peekElemOff pbuf i
              if (c == '\n' && i > r)
                 then do
                         c1 <- peekElemOff pbuf (i-1)
                         if (c1 == '\r')
                            then unpackRB ('\n':acc) (i-2)
                            else unpackRB ('\n':acc) (i-1)
                 else do
309
                         unpackRB (c : acc) (i-1)
310
311
312
     in do
     c <- peekElemOff pbuf (w-1)
     if (c == '\r')
313
        then do
314
315
316
317
318
319
320
321
322
                -- If the last char is a '\r', we need to know whether or
                -- not it is followed by a '\n', so leave it in the buffer
                -- for now and just unpack the rest.
                str <- unpackRB acc0 (w-2)
                return (str, w-1)
        else do
                str <- unpackRB acc0 (w-1)
                return (str, w)

323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
-- Note [#5536]
--
-- We originally had
--
--    let c' = desurrogatifyRoundtripCharacter c in
--    c' `seq` unpackRB (c':acc) (i-1)
--
-- but this resulted in Core like
--
--    case (case x <# y of True -> C# e1; False -> C# e2) of c
--      C# _ -> unpackRB (c:acc) (i-1)
--
-- which compiles into a continuation for the outer case, with each
-- branch of the inner case building a C# and then jumping to the
-- continuation.  We'd rather not have this extra jump, which makes
-- quite a difference to performance (see #5536) It turns out that
-- matching on the C# directly causes GHC to do the case-of-case,
-- giving much straighter code.
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377

-- -----------------------------------------------------------------------------
-- hGetContents

-- hGetContents on a DuplexHandle only affects the read side: you can
-- carry on writing to it afterwards.

-- | Computation 'hGetContents' @hdl@ returns the list of characters
-- corresponding to the unread portion of the channel or file managed
-- by @hdl@, which is put into an intermediate state, /semi-closed/.
-- In this state, @hdl@ is effectively closed,
-- but items are read from @hdl@ on demand and accumulated in a special
-- list returned by 'hGetContents' @hdl@.
--
-- Any operation that fails because a handle is closed,
-- also fails if a handle is semi-closed.  The only exception is 'hClose'.
-- A semi-closed handle becomes closed:
--
--  * if 'hClose' is applied to it;
--
--  * if an I\/O error occurs when reading an item from the handle;
--
--  * or once the entire contents of the handle has been read.
--
-- Once a semi-closed handle becomes closed, the contents of the
-- associated list becomes fixed.  The contents of this final list is
-- only partially specified: it will contain at least all the items of
-- the stream that were evaluated prior to the handle becoming closed.
--
-- Any I\/O errors encountered while a handle is semi-closed are simply
-- discarded.
--
-- This operation may fail with:
--
--  * 'isEOFError' if the end of file has been reached.

hGetContents :: Handle -> IO String
378
hGetContents handle =
379
380
381
382
383
384
385
386
387
   wantReadableHandle "hGetContents" handle $ \handle_ -> do
      xs <- lazyRead handle
      return (handle_{ haType=SemiClosedHandle}, xs )

-- Note that someone may close the semi-closed handle (or change its
-- buffering), so each time these lazy read functions are pulled on,
-- they have to check whether the handle has indeed been closed.

lazyRead :: Handle -> IO String
388
lazyRead handle =
389
   unsafeInterleaveIO $
390
        withHandle "hGetContents" handle $ \ handle_ -> do
391
392
        case haType handle_ of
          SemiClosedHandle -> lazyReadBuffered handle handle_
393
394
395
396
          ClosedHandle
            -> ioException
                  (IOError (Just handle) IllegalOperation "hGetContents"
                        "delayed read on closed handle" Nothing Nothing)
397
          _ -> ioException
398
                  (IOError (Just handle) IllegalOperation "hGetContents"
399
400
401
402
403
                        "illegal handle type" Nothing Nothing)

lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
lazyReadBuffered h handle_@Handle__{..} = do
   buf <- readIORef haCharBuffer
404
405
   Exception.catch
        (do
406
407
408
409
410
411
412
413
414
415
416
417
418
            buf'@Buffer{..} <- getSomeCharacters handle_ buf
            lazy_rest <- lazyRead h
            (s,r) <- if haInputNL == CRLF
                         then unpack_nl bufRaw bufL bufR lazy_rest
                         else do s <- unpack bufRaw bufL bufR lazy_rest
                                 return (s,bufR)
            writeIORef haCharBuffer (bufferAdjustL r buf')
            return (handle_, s)
        )
        (\e -> do (handle_', _) <- hClose_help handle_
                  debugIO ("hGetContents caught: " ++ show e)
                  -- We might have a \r cached in CRLF mode.  So we
                  -- need to check for that and return it:
419
420
421
422
423
424
425
426
                  let r = if isEOFError e
                             then if not (isEmptyBuffer buf)
                                     then "\r"
                                     else ""
                             else
                                  throw (augmentIOError e "hGetContents" h)

                  return (handle_', r)
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
        )

-- ensure we have some characters in the buffer
getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
  case bufferElems buf of

    -- buffer empty: read some more
    0 -> readTextDevice handle_ buf

    -- if the buffer has a single '\r' in it and we're doing newline
    -- translation: read some more
    1 | haInputNL == CRLF -> do
      (c,_) <- readCharBuf bufRaw bufL
      if c == '\r'
         then do -- shuffle the '\r' to the beginning.  This is only safe
                 -- if we're about to call readTextDevice, otherwise it
                 -- would mess up flushCharBuffer.
                 -- See [note Buffer Flushing], GHC.IO.Handle.Types
446
                 _ <- writeCharBuf bufRaw 0 '\r'
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
                 let buf' = buf{ bufL=0, bufR=1 }
                 readTextDevice handle_ buf'
         else do
                 return buf

    -- buffer has some chars in it already: just return it
    _otherwise ->
      return buf

-- ---------------------------------------------------------------------------
-- hPutChar

-- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
-- file or channel managed by @hdl@.  Characters may be buffered if
-- buffering is enabled for @hdl@.
--
-- This operation may fail with:
--
--  * 'isFullError' if the device is full; or
--
--  * 'isPermissionError' if another system resource limit would be exceeded.

hPutChar :: Handle -> Char -> IO ()
hPutChar handle c = do
    c `seq` return ()
    wantWritableHandle "hPutChar" handle $ \ handle_  -> do
473
     hPutcBuffered handle_ c
474

475
476
hPutcBuffered :: Handle__ -> Char -> IO ()
hPutcBuffered handle_@Handle__{..} c = do
477
478
479
480
481
482
483
484
  buf <- readIORef haCharBuffer
  if c == '\n'
     then do buf1 <- if haOutputNL == CRLF
                        then do
                          buf1 <- putc buf '\r'
                          putc buf1 '\n'
                        else do
                          putc buf '\n'
485
486
             writeCharBuffer handle_ buf1
             when is_line $ flushByteWriteBuffer handle_
487
488
      else do
          buf1 <- putc buf c
489
490
          writeCharBuffer handle_ buf1
          return ()
491
  where
492
493
494
495
    is_line = case haBufferMode of
                LineBuffering -> True
                _             -> False

496
497
498
    putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
       debugIO ("putc: " ++ summaryBuffer buf)
       w'  <- writeCharBuf raw w c
499
       return buf{ bufR = w' }
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530

-- ---------------------------------------------------------------------------
-- hPutStr

-- We go to some trouble to avoid keeping the handle locked while we're
-- evaluating the string argument to hPutStr, in case doing so triggers another
-- I/O operation on the same handle which would lead to deadlock.  The classic
-- case is
--
--              putStr (trace "hello" "world")
--
-- so the basic scheme is this:
--
--      * copy the string into a fresh buffer,
--      * "commit" the buffer to the handle.
--
-- Committing may involve simply copying the contents of the new
-- buffer into the handle's buffer, flushing one or both buffers, or
-- maybe just swapping the buffers over (if the handle's buffer was
-- empty).  See commitBuffer below.

-- | Computation 'hPutStr' @hdl s@ writes the string
-- @s@ to the file or channel managed by @hdl@.
--
-- This operation may fail with:
--
--  * 'isFullError' if the device is full; or
--
--  * 'isPermissionError' if another system resource limit would be exceeded.

hPutStr :: Handle -> String -> IO ()
531
532
533
534
535
536
537
538
539
hPutStr handle str = hPutStr' handle str False

-- | The same as 'hPutStr', but adds a newline character.
hPutStrLn :: Handle -> String -> IO ()
hPutStrLn handle str = hPutStr' handle str True
  -- An optimisation: we treat hPutStrLn specially, to avoid the
  -- overhead of a single putChar '\n', which is quite high now that we
  -- have to encode eagerly.

540
{-# NOINLINE hPutStr' #-}
541
542
543
544
hPutStr' :: Handle -> String -> Bool -> IO ()
hPutStr' handle str add_nl =
  do
    (buffer_mode, nl) <-
545
546
547
548
549
550
551
         wantWritableHandle "hPutStr" handle $ \h_ -> do
                       bmode <- getSpareBuffer h_
                       return (bmode, haOutputNL h_)

    case buffer_mode of
       (NoBuffering, _) -> do
            hPutChars handle str        -- v. slow, but we don't care
552
            when add_nl $ hPutChar handle '\n'
553
       (LineBuffering, buf) -> do
554
            writeBlocks handle True  add_nl nl buf str
555
       (BlockBuffering _, buf) -> do
556
            writeBlocks handle False add_nl nl buf str
557
558
559
560
561
562

hPutChars :: Handle -> [Char] -> IO ()
hPutChars _      [] = return ()
hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs

getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
563
getSpareBuffer Handle__{haCharBuffer=ref,
564
565
566
567
                        haBuffers=spare_ref,
                        haBufferMode=mode}
 = do
   case mode of
Eric Seidel's avatar
Eric Seidel committed
568
     NoBuffering -> return (mode, errorWithoutStackTrace "no buffer!")
569
570
571
572
573
574
575
576
577
578
579
580
581
     _ -> do
          bufs <- readIORef spare_ref
          buf  <- readIORef ref
          case bufs of
            BufferListCons b rest -> do
                writeIORef spare_ref rest
                return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
            BufferListNil -> do
                new_buf <- newCharBuffer (bufSize buf) WriteBuffer
                return (mode, new_buf)


-- NB. performance-critical code: eyeball the Core.
582
583
writeBlocks :: Handle -> Bool -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
writeBlocks hdl line_buffered add_nl nl
584
585
            buf@Buffer{ bufRaw=raw, bufSize=len } s =
  let
586
587
588
589
590
591
   shoveString :: Int -> [Char] -> [Char] -> IO ()
   shoveString !n [] [] = do
        commitBuffer hdl raw len n False{-no flush-} True{-release-}
   shoveString !n [] rest = do
        shoveString n rest []
   shoveString !n (c:cs) rest
592
593
     -- n+1 so we have enough room to write '\r\n' if necessary
     | n + 1 >= len = do
594
595
        commitBuffer hdl raw len n False{-flush-} False
        shoveString 0 (c:cs) rest
596
597
     | c == '\n'  =  do
        n' <- if nl == CRLF
598
                 then do
599
600
601
602
603
604
                    n1 <- writeCharBuf raw n  '\r'
                    writeCharBuf raw n1 '\n'
                 else do
                    writeCharBuf raw n c
        if line_buffered
           then do
605
606
607
                -- end of line, so write and flush
               commitBuffer hdl raw len n' True{-flush-} False
               shoveString 0 cs rest
608
           else do
609
               shoveString n' cs rest
610
     | otherwise = do
611
        n' <- writeCharBuf raw n c
612
        shoveString n' cs rest
613
  in
614
  shoveString 0 s (if add_nl then "\n" else "")
615
616
617

-- -----------------------------------------------------------------------------
-- commitBuffer handle buf sz count flush release
618
--
619
620
621
622
623
624
625
626
627
-- Write the contents of the buffer 'buf' ('sz' bytes long, containing
-- 'count' bytes of data) to handle (handle must be block or line buffered).

commitBuffer
        :: Handle                       -- handle to commit to
        -> RawCharBuffer -> Int         -- address and size (in bytes) of buffer
        -> Int                          -- number of bytes of data in buffer
        -> Bool                         -- True <=> flush the handle afterward
        -> Bool                         -- release the buffer?
628
        -> IO ()
629

630
commitBuffer hdl !raw !sz !count flush release =
631
632
633
  wantWritableHandle "commitBuffer" hdl $ \h_@Handle__{..} -> do
      debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
            ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
634

635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
      writeCharBuffer h_ Buffer{ bufRaw=raw, bufState=WriteBuffer,
                                 bufL=0, bufR=count, bufSize=sz }

      when flush $ flushByteWriteBuffer h_

      -- release the buffer if necessary
      when release $ do
          -- find size of current buffer
          old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer
          when (sz == size) $ do
               spare_bufs <- readIORef haBuffers
               writeIORef haBuffers (BufferListCons raw spare_bufs)

      return ()

-- backwards compatibility; the text package uses this
651
652
commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
              -> IO CharBuffer
653
654
commitBuffer' raw sz@(I# _) count@(I# _) flush release h_@Handle__{..}
   = do
655
656
657
      debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
            ++ ", flush=" ++ show flush ++ ", release=" ++ show release)

658
659
660
661
662
663
      let this_buf = Buffer{ bufRaw=raw, bufState=WriteBuffer,
                             bufL=0, bufR=count, bufSize=sz }

      writeCharBuffer h_ this_buf

      when flush $ flushByteWriteBuffer h_
664
665

      -- release the buffer if necessary
666
667
668
669
670
671
672
673
      when release $ do
          -- find size of current buffer
          old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer
          when (sz == size) $ do
               spare_bufs <- readIORef haBuffers
               writeIORef haBuffers (BufferListCons raw spare_bufs)

      return this_buf
674
675
676
677
678
679
680
681
682
683
684
685
686

-- ---------------------------------------------------------------------------
-- Reading/writing sequences of bytes.

-- ---------------------------------------------------------------------------
-- hPutBuf

-- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
-- buffer @buf@ to the handle @hdl@.  It returns ().
--
-- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
-- writing the bytes directly to the underlying file or device.
--
687
688
689
-- 'hPutBuf' ignores the prevailing 'TextEncoding' and
-- 'NewlineMode' on the 'Handle', and writes bytes directly.
--
690
691
692
693
694
695
696
697
698
699
700
-- This operation may fail with:
--
--  * 'ResourceVanished' if the handle is a pipe or socket, and the
--    reading end is closed.  (If this is a POSIX system, and the program
--    has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
--    instead, whose default action is to terminate the program).

hPutBuf :: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> IO ()
701
702
hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
                         return ()
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718

hPutBufNonBlocking
        :: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> IO Int                       -- returns: number of bytes written
hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False

hPutBuf':: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> Bool                         -- allow blocking?
        -> IO Int
hPutBuf' handle ptr count can_block
  | count == 0 = return 0
  | count <  0 = illegalBufferSize handle "hPutBuf" count
719
720
  | otherwise =
    wantWritableHandle "hPutBuf" handle $
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
      \ h_@Handle__{..} -> do
          debugIO ("hPutBuf count=" ++ show count)

          r <- bufWrite h_ (castPtr ptr) count can_block

          -- we must flush if this Handle is set to NoBuffering.  If
          -- it is set to LineBuffering, be conservative and flush
          -- anyway (we didn't check for newlines in the data).
          case haBufferMode of
             BlockBuffering _      -> do return ()
             _line_or_no_buffering -> do flushWriteBuffer h_
          return r

bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
bufWrite h_@Handle__{..} ptr count can_block =
  seq count $ do  -- strictness hack
  old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
     <- readIORef haByteBuffer

740
741
742
743
744
745
746
747
748
  -- TODO: Possible optimisation:
  --       If we know that `w + count > size`, we should write both the
  --       handle buffer and the `ptr` in a single `writev()` syscall.

  -- Need to buffer and enough room in handle buffer?
  -- There's no need to buffer if the data to be written is larger than
  -- the handle buffer (`count >= size`).
  if (count < size && count <= size - w)
        -- We need to buffer and there's enough room in the buffer:
749
750
        -- just copy the data in and update bufR.
        then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
751
                copyToRawBuffer old_raw w ptr count
752
753
754
755
756
757
758
759
760
761
762
763
                let copied_buf = old_buf{ bufR = w + count }
                -- If the write filled the buffer completely, we need to flush,
                -- to maintain the "INVARIANTS on Buffers" from
                -- GHC.IO.Buffer.checkBuffer: "a write buffer is never full".
                if (count == size - w)
                  then do
                    debugIO "hPutBuf: flushing full buffer after writing"
                    flushed_buf <- Buffered.flushWriteBuffer haDevice copied_buf
                            -- TODO: we should do a non-blocking flush here
                    writeIORef haByteBuffer flushed_buf
                  else do
                    writeIORef haByteBuffer copied_buf
764
765
                return count

766
767
768
769
770
771
772
773
        -- else, we have to flush any existing handle buffer data
        -- and can then write out the data in `ptr` directly.
        else do -- No point flushing when there's nothing in the buffer.
                when (w > 0) $ do
                  debugIO "hPutBuf: flushing first"
                  flushed_buf <- Buffered.flushWriteBuffer haDevice old_buf
                          -- TODO: we should do a non-blocking flush here
                  writeIORef haByteBuffer flushed_buf
774
                -- if we can fit in the buffer, then just loop
775
776
777
778
779
780
781
782
783
784
785
786
787
                if count < size
                   then bufWrite h_ ptr count can_block
                   else if can_block
                           then do writeChunk h_ (castPtr ptr) count
                                   return count
                           else writeChunkNonBlocking h_ (castPtr ptr) count

writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
writeChunk h_@Handle__{..} ptr bytes
  | Just fd <- cast haDevice  =  RawIO.write (fd::FD) ptr bytes
  | otherwise = error "Todo: hPutBuf"

writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
788
writeChunkNonBlocking h_@Handle__{..} ptr bytes
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
  | Just fd <- cast haDevice  =  RawIO.writeNonBlocking (fd::FD) ptr bytes
  | otherwise = error "Todo: hPutBuf"

-- ---------------------------------------------------------------------------
-- hGetBuf

-- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
-- into the buffer @buf@ until either EOF is reached or
-- @count@ 8-bit bytes have been read.
-- It returns the number of bytes actually read.  This may be zero if
-- EOF was reached before any data was read (or if @count@ is zero).
--
-- 'hGetBuf' never raises an EOF exception, instead it returns a value
-- smaller than @count@.
--
-- If the handle is a pipe or socket, and the writing end
-- is closed, 'hGetBuf' will behave as if EOF was reached.
--
807
808
-- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode'
-- on the 'Handle', and reads bytes directly.
809
810
811
812
813

hGetBuf :: Handle -> Ptr a -> Int -> IO Int
hGetBuf h ptr count
  | count == 0 = return 0
  | count <  0 = illegalBufferSize h "hGetBuf" count
814
  | otherwise =
815
      wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do
816
         flushCharReadBuffer h_
817
818
819
820
821
         buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
            <- readIORef haByteBuffer
         if isEmptyBuffer buf
            then bufReadEmpty    h_ buf (castPtr ptr) 0 count
            else bufReadNonEmpty h_ buf (castPtr ptr) 0 count
822
823
824
825

-- small reads go through the buffer, large reads are satisfied by
-- taking data first from the buffer and then direct from the file
-- descriptor.
826
827
828
829

bufReadNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadNonEmpty h_@Handle__{..}
                buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
830
                ptr !so_far !count
831
 = do
832
833
        let avail = w - r
        if (count < avail)
834
           then do
835
836
837
838
                copyFromRawBuffer ptr raw r count
                writeIORef haByteBuffer buf{ bufL = r + count }
                return (so_far + count)
           else do
839

840
        copyFromRawBuffer ptr raw r avail
841
842
        let buf' = buf{ bufR=0, bufL=0 }
        writeIORef haByteBuffer buf'
843
844
845
846
        let remaining = count - avail
            so_far' = so_far + avail
            ptr' = ptr `plusPtr` avail

847
        if remaining == 0
848
849
850
851
852
853
854
855
856
857
858
           then return so_far'
           else bufReadEmpty h_ buf' ptr' so_far' remaining


bufReadEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadEmpty h_@Handle__{..}
             buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
             ptr so_far count
 | count > sz, Just fd <- cast haDevice = loop fd 0 count
 | otherwise = do
     (r,buf') <- Buffered.fillReadBuffer haDevice buf
859
     if r == 0
860
861
862
        then return so_far
        else do writeIORef haByteBuffer buf'
                bufReadNonEmpty h_ buf' ptr so_far count
863
864
 where
  loop :: FD -> Int -> Int -> IO Int
865
  loop fd off bytes | bytes <= 0 = return (so_far + off)
866
  loop fd off bytes = do
867
    r <- RawIO.read (fd::FD) (ptr `plusPtr` off) bytes
868
    if r == 0
869
        then return (so_far + off)
870
871
        else loop fd (off + r) (bytes - r)

872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
-- ---------------------------------------------------------------------------
-- hGetBufSome

-- | 'hGetBufSome' @hdl buf count@ reads data from the handle @hdl@
-- into the buffer @buf@.  If there is any data available to read,
-- then 'hGetBufSome' returns it immediately; it only blocks if there
-- is no data to be read.
--
-- It returns the number of bytes actually read.  This may be zero if
-- EOF was reached before any data was read (or if @count@ is zero).
--
-- 'hGetBufSome' never raises an EOF exception, instead it returns a value
-- smaller than @count@.
--
-- If the handle is a pipe or socket, and the writing end
-- is closed, 'hGetBufSome' will behave as if EOF was reached.
--
-- 'hGetBufSome' ignores the prevailing 'TextEncoding' and 'NewlineMode'
-- on the 'Handle', and reads bytes directly.

hGetBufSome :: Handle -> Ptr a -> Int -> IO Int
hGetBufSome h ptr count
  | count == 0 = return 0
Simon Marlow's avatar
Simon Marlow committed
895
  | count <  0 = illegalBufferSize h "hGetBufSome" count
896
  | otherwise =
Simon Marlow's avatar
Simon Marlow committed
897
      wantReadableHandle_ "hGetBufSome" h $ \ h_@Handle__{..} -> do
898
899
900
         flushCharReadBuffer h_
         buf@Buffer{ bufSize=sz } <- readIORef haByteBuffer
         if isEmptyBuffer buf
901
902
903
            then case count > sz of  -- large read? optimize it with a little special case:
                    True | Just fd <- haFD h_ -> do RawIO.read fd (castPtr ptr) count
                    _ -> do (r,buf') <- Buffered.fillReadBuffer haDevice buf
904
905
906
                            if r == 0
                               then return 0
                               else do writeIORef haByteBuffer buf'
Simon Marlow's avatar
Simon Marlow committed
907
908
909
910
                                       bufReadNBNonEmpty h_ buf' (castPtr ptr) 0 (min r count)
                                        -- new count is  (min r count), so
                                        -- that bufReadNBNonEmpty will not
                                        -- issue another read.
911
            else
912
913
              let count' = min count (bufferElems buf)
              in bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count'
914

915
916
haFD :: Handle__ -> Maybe FD
haFD h_@Handle__{..} = cast haDevice
917

918
919
920
921
922
923
924
925
926
927
928
929
930
-- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
-- into the buffer @buf@ until either EOF is reached, or
-- @count@ 8-bit bytes have been read, or there is no more data available
-- to read immediately.
--
-- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
-- never block waiting for data to become available, instead it returns
-- only whatever data is available.  To wait for data to arrive before
-- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
--
-- If the handle is a pipe or socket, and the writing end
-- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
--
931
932
-- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and
-- 'NewlineMode' on the 'Handle', and reads bytes directly.
933
934
935
--
-- NOTE: on Windows, this function does not work correctly; it
-- behaves identically to 'hGetBuf'.
936

937
938
939
940
hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
hGetBufNonBlocking h ptr count
  | count == 0 = return 0
  | count <  0 = illegalBufferSize h "hGetBufNonBlocking" count
941
  | otherwise =
942
      wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_@Handle__{..} -> do
943
         flushCharReadBuffer h_
944
945
946
947
948
         buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
            <- readIORef haByteBuffer
         if isEmptyBuffer buf
            then bufReadNBEmpty    h_ buf (castPtr ptr) 0 count
            else bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count
949
950
951
952
953

bufReadNBEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadNBEmpty   h_@Handle__{..}
                 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
                 ptr so_far count
954
  | count > sz,
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
    Just fd <- cast haDevice = do
       m <- RawIO.readNonBlocking (fd::FD) ptr count
       case m of
         Nothing -> return so_far
         Just n  -> return (so_far + n)

 | otherwise = do
     buf <- readIORef haByteBuffer
     (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
     case r of
       Nothing -> return so_far
       Just 0  -> return so_far
       Just r  -> do
         writeIORef haByteBuffer buf'
         bufReadNBNonEmpty h_ buf' ptr so_far (min count r)
                          -- NOTE: new count is    min count r
971
972
973
974
                          -- so we will just copy the contents of the
                          -- buffer in the recursive call, and not
                          -- loop again.

975

976
977
978
979
980
bufReadNBNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadNBNonEmpty h_@Handle__{..}
                  buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
                  ptr so_far count
  = do
981
982
        let avail = w - r
        if (count < avail)
983
           then do
984
985
986
987
988
                copyFromRawBuffer ptr raw r count
                writeIORef haByteBuffer buf{ bufL = r + count }
                return (so_far + count)
           else do

989
        copyFromRawBuffer ptr raw r avail
990
991
        let buf' = buf{ bufR=0, bufL=0 }
        writeIORef haByteBuffer buf'
992
993
994
995
        let remaining = count - avail
            so_far' = so_far + avail
            ptr' = ptr `plusPtr` avail

996
997
998
        if remaining == 0
           then return so_far'
           else bufReadNBEmpty h_ buf' ptr' so_far' remaining
999
1000
1001
1002
1003

-- ---------------------------------------------------------------------------
-- memcpy wrappers

copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
1004
copyToRawBuffer raw off ptr bytes =
1005
 withRawBuffer raw $ \praw ->
1006
1007
   do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
      return ()
1008
1009

copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
1010
copyFromRawBuffer ptr raw off bytes =
1011
 withRawBuffer raw $ \praw ->
1012
1013
   do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
      return ()
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026

foreign import ccall unsafe "memcpy"
   memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())

-----------------------------------------------------------------------------
-- Internal Utils

illegalBufferSize :: Handle -> String -> Int -> IO a
illegalBufferSize handle fn sz =
        ioException (IOError (Just handle)
                            InvalidArgument  fn
                            ("illegal buffer size " ++ showsPrec 9 sz [])
                            Nothing Nothing)
dterei's avatar
dterei committed
1027