{-# LANGUAGE BangPatterns, RecordWildCards #-}
{-# LANGUAGE MagicHash #-}
-- |
-- Module      : Data.Text.Internal.IO
-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan,
--               (c) 2009 Simon Marlow
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- /Warning/: this is an internal module, and does not have a stable
-- API or name. Functions in this module may not check or enforce
-- preconditions expected by public modules. Use at your own risk!
--
-- Low-level support for text I\/O.

module Data.Text.Internal.IO
    (
      hGetLineWith
    , readChunk
    , hPutStream
    , hPutStr
    , hPutStrLn
    ) where

import qualified Control.Exception as E
import qualified Data.ByteString as B
import Data.ByteString.Builder (hPutBuilder, charUtf8)
import Data.IORef (readIORef, writeIORef)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, encodeUtf8Builder)
import Data.Text.Internal.Fusion (stream, streamLn, unstream)
import Data.Text.Internal.Fusion.Types (Step(..), Stream(..))
import Data.Text.Internal.Fusion.Size (exactSize, maxSize)
import Data.Text.Unsafe (inlinePerformIO)
import Foreign.Storable (peekElemOff)
import GHC.Exts (reallyUnsafePtrEquality#, isTrue#)
import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBuffer, RawCharBuffer,
                      bufferAdjustL, bufferElems, charSize, emptyBuffer,
                      isEmptyBuffer, newCharBuffer, readCharBuf, withRawBuffer,
                      writeCharBuf)
import GHC.IO.Handle.Internals (ioe_EOF, readTextDevice, wantReadableHandle_,
                                wantWritableHandle)
import GHC.IO.Handle.Text (commitBuffer')
import GHC.IO.Handle.Types (BufferList(..), BufferMode(..), Handle__(..), Newline(..))
import System.IO (Handle, hPutChar, utf8)
import System.IO.Error (isEOFError)
import qualified Data.Text as T

-- | Read a single line of input from a handle, constructing a list of
-- decoded chunks as we go.  When we're done, transform them into the
-- destination type.
hGetLineWith :: ([Text] -> t) -> Handle -> IO t
hGetLineWith :: forall t. ([Text] -> t) -> Handle -> IO t
hGetLineWith [Text] -> t
f Handle
h = String -> Handle -> (Handle__ -> IO t) -> IO t
forall a. String -> Handle -> (Handle__ -> IO a) -> IO a
wantReadableHandle_ String
"hGetLine" Handle
h Handle__ -> IO t
go
  where
    go :: Handle__ -> IO t
go hh :: Handle__
hh@Handle__{dev
Maybe (MVar Handle__)
Maybe TextEncoding
Maybe (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
IORef (dec_state, Buffer Word8)
IORef (Buffer CharBufElem)
IORef (Buffer Word8)
IORef (BufferList CharBufElem)
Newline
BufferMode
HandleType
haDevice :: dev
haType :: HandleType
haByteBuffer :: IORef (Buffer Word8)
haBufferMode :: BufferMode
haLastDecode :: IORef (dec_state, Buffer Word8)
haCharBuffer :: IORef (Buffer CharBufElem)
haBuffers :: IORef (BufferList CharBufElem)
haEncoder :: Maybe (TextEncoder enc_state)
haDecoder :: Maybe (TextDecoder dec_state)
haCodec :: Maybe TextEncoding
haInputNL :: Newline
haOutputNL :: Newline
haOtherSide :: Maybe (MVar Handle__)
haOtherSide :: Handle__ -> Maybe (MVar Handle__)
haOutputNL :: Handle__ -> Newline
haInputNL :: Handle__ -> Newline
haCodec :: Handle__ -> Maybe TextEncoding
haDecoder :: ()
haEncoder :: ()
haBuffers :: Handle__ -> IORef (BufferList CharBufElem)
haCharBuffer :: Handle__ -> IORef (Buffer CharBufElem)
haLastDecode :: ()
haBufferMode :: Handle__ -> BufferMode
haByteBuffer :: Handle__ -> IORef (Buffer Word8)
haType :: Handle__ -> HandleType
haDevice :: ()
..} = IORef (Buffer CharBufElem) -> IO (Buffer CharBufElem)
forall a. IORef a -> IO a
readIORef IORef (Buffer CharBufElem)
haCharBuffer IO (Buffer CharBufElem) -> (Buffer CharBufElem -> IO t) -> IO t
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Text] -> t) -> IO [Text] -> IO t
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> t
f (IO [Text] -> IO t)
-> (Buffer CharBufElem -> IO [Text]) -> Buffer CharBufElem -> IO t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle__ -> [Text] -> Buffer CharBufElem -> IO [Text]
hGetLineLoop Handle__
hh []

hGetLineLoop :: Handle__ -> [Text] -> CharBuffer -> IO [Text]
hGetLineLoop :: Handle__ -> [Text] -> Buffer CharBufElem -> IO [Text]
hGetLineLoop hh :: Handle__
hh@Handle__{dev
Maybe (MVar Handle__)
Maybe TextEncoding
Maybe (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
IORef (dec_state, Buffer Word8)
IORef (Buffer CharBufElem)
IORef (Buffer Word8)
IORef (BufferList CharBufElem)
Newline
BufferMode
HandleType
haOtherSide :: Handle__ -> Maybe (MVar Handle__)
haOutputNL :: Handle__ -> Newline
haInputNL :: Handle__ -> Newline
haCodec :: Handle__ -> Maybe TextEncoding
haDecoder :: ()
haEncoder :: ()
haBuffers :: Handle__ -> IORef (BufferList CharBufElem)
haCharBuffer :: Handle__ -> IORef (Buffer CharBufElem)
haLastDecode :: ()
haBufferMode :: Handle__ -> BufferMode
haByteBuffer :: Handle__ -> IORef (Buffer Word8)
haType :: Handle__ -> HandleType
haDevice :: ()
haDevice :: dev
haType :: HandleType
haByteBuffer :: IORef (Buffer Word8)
haBufferMode :: BufferMode
haLastDecode :: IORef (dec_state, Buffer Word8)
haCharBuffer :: IORef (Buffer CharBufElem)
haBuffers :: IORef (BufferList CharBufElem)
haEncoder :: Maybe (TextEncoder enc_state)
haDecoder :: Maybe (TextDecoder dec_state)
haCodec :: Maybe TextEncoding
haInputNL :: Newline
haOutputNL :: Newline
haOtherSide :: Maybe (MVar Handle__)
..} = [Text] -> Buffer CharBufElem -> IO [Text]
go where
 go :: [Text] -> Buffer CharBufElem -> IO [Text]
go [Text]
ts buf :: Buffer CharBufElem
buf@Buffer{ bufL :: forall e. Buffer e -> Int
bufL=Int
r0, bufR :: forall e. Buffer e -> Int
bufR=Int
w, bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer CharBufElem
raw0 } = do
  let findEOL :: RawBuffer CharBufElem -> Int -> IO (Bool, Int)
findEOL RawBuffer CharBufElem
raw Int
r | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
w    = (Bool, Int) -> IO (Bool, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Int
w)
                    | Bool
otherwise = do
        (c,r') <- RawBuffer CharBufElem -> Int -> IO (CharBufElem, Int)
readCharBuf RawBuffer CharBufElem
raw Int
r
        if c == '\n'
          then return (True, r)
          else findEOL raw r'
  (eol, off) <- RawBuffer CharBufElem -> Int -> IO (Bool, Int)
findEOL RawBuffer CharBufElem
raw0 Int
r0
  (t,r') <- if haInputNL == CRLF
            then unpack_nl raw0 r0 off
            else do t <- unpack raw0 r0 off
                    return (t,off)
  if eol
    then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
            return $ reverse (t:ts)
    else do
      let buf1 = Int -> Buffer CharBufElem -> Buffer CharBufElem
forall e. Int -> Buffer e -> Buffer e
bufferAdjustL Int
r' Buffer CharBufElem
buf
      maybe_buf <- maybeFillReadBuffer hh buf1
      case maybe_buf of
         -- Nothing indicates we caught an EOF, and we may have a
         -- partial line to return.
         Maybe (Buffer CharBufElem)
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.
              let pre :: Text
pre | Buffer CharBufElem -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer CharBufElem
buf1 = Text
T.empty
                      | Bool
otherwise          = CharBufElem -> Text
T.singleton CharBufElem
'\r'
              IORef (Buffer CharBufElem) -> Buffer CharBufElem -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Buffer CharBufElem)
haCharBuffer Buffer CharBufElem
buf1{ bufL=0, bufR=0 }
              let str :: [Text]
str = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
preText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:Text
tText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
ts
              if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
str
                then IO [Text]
forall a. IO a
ioe_EOF
                else [Text] -> IO [Text]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
str
         Just Buffer CharBufElem
new_buf -> [Text] -> Buffer CharBufElem -> IO [Text]
go (Text
tText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
ts) Buffer CharBufElem
new_buf

-- This function is lifted almost verbatim from GHC.IO.Handle.Text.
maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
maybeFillReadBuffer :: Handle__ -> Buffer CharBufElem -> IO (Maybe (Buffer CharBufElem))
maybeFillReadBuffer Handle__
handle_ Buffer CharBufElem
buf
  = IO (Maybe (Buffer CharBufElem))
-> (IOError -> IO (Maybe (Buffer CharBufElem)))
-> IO (Maybe (Buffer CharBufElem))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (Buffer CharBufElem -> Maybe (Buffer CharBufElem)
forall a. a -> Maybe a
Just (Buffer CharBufElem -> Maybe (Buffer CharBufElem))
-> IO (Buffer CharBufElem) -> IO (Maybe (Buffer CharBufElem))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Handle__ -> Buffer CharBufElem -> IO (Buffer CharBufElem)
getSomeCharacters Handle__
handle_ Buffer CharBufElem
buf) ((IOError -> IO (Maybe (Buffer CharBufElem)))
 -> IO (Maybe (Buffer CharBufElem)))
-> (IOError -> IO (Maybe (Buffer CharBufElem)))
-> IO (Maybe (Buffer CharBufElem))
forall a b. (a -> b) -> a -> b
$ \IOError
e ->
      if IOError -> Bool
isEOFError IOError
e
      then Maybe (Buffer CharBufElem) -> IO (Maybe (Buffer CharBufElem))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Buffer CharBufElem)
forall a. Maybe a
Nothing
      else IOError -> IO (Maybe (Buffer CharBufElem))
forall a. (?callStack::CallStack) => IOError -> IO a
ioError IOError
e

unpack :: RawCharBuffer -> Int -> Int -> IO Text
unpack :: RawBuffer CharBufElem -> Int -> Int -> IO Text
unpack !RawBuffer CharBufElem
buf !Int
r !Int
w
 | Int
charSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
4 = String -> IO Text
forall a. String -> a
sizeError String
"unpack"
 | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
w        = Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
T.empty
 | Bool
otherwise     = RawBuffer CharBufElem -> (Ptr CharBufElem -> IO Text) -> IO Text
forall e a. RawBuffer e -> (Ptr e -> IO a) -> IO a
withRawBuffer RawBuffer CharBufElem
buf Ptr CharBufElem -> IO Text
forall {m :: * -> *}. Monad m => Ptr CharBufElem -> m Text
go
 where
  go :: Ptr CharBufElem -> m Text
go Ptr CharBufElem
pbuf = Text -> m Text
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$! Stream CharBufElem -> Text
unstream ((Int -> Step Int CharBufElem) -> Int -> Size -> Stream CharBufElem
forall a s. (s -> Step s a) -> s -> Size -> Stream a
Stream Int -> Step Int CharBufElem
next Int
r (Int -> Size
exactSize (Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
r)))
   where
    next :: Int -> Step Int CharBufElem
next !Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
w    = Step Int CharBufElem
forall s a. Step s a
Done
            | Bool
otherwise = CharBufElem -> Int -> Step Int CharBufElem
forall s a. a -> s -> Step s a
Yield (Int -> CharBufElem
ix Int
i) (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    ix :: Int -> CharBufElem
ix Int
i = IO CharBufElem -> CharBufElem
forall a. IO a -> a
inlinePerformIO (IO CharBufElem -> CharBufElem) -> IO CharBufElem -> CharBufElem
forall a b. (a -> b) -> a -> b
$ Ptr CharBufElem -> Int -> IO CharBufElem
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CharBufElem
pbuf Int
i

unpack_nl :: RawCharBuffer -> Int -> Int -> IO (Text, Int)
unpack_nl :: RawBuffer CharBufElem -> Int -> Int -> IO (Text, Int)
unpack_nl !RawBuffer CharBufElem
buf !Int
r !Int
w
 | Int
charSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
4 = String -> IO (Text, Int)
forall a. String -> a
sizeError String
"unpack_nl"
 | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
w        = (Text, Int) -> IO (Text, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
T.empty, Int
0)
 | Bool
otherwise     = RawBuffer CharBufElem
-> (Ptr CharBufElem -> IO (Text, Int)) -> IO (Text, Int)
forall e a. RawBuffer e -> (Ptr e -> IO a) -> IO a
withRawBuffer RawBuffer CharBufElem
buf ((Ptr CharBufElem -> IO (Text, Int)) -> IO (Text, Int))
-> (Ptr CharBufElem -> IO (Text, Int)) -> IO (Text, Int)
forall a b. (a -> b) -> a -> b
$ Ptr CharBufElem -> IO (Text, Int)
forall {m :: * -> *}. Monad m => Ptr CharBufElem -> m (Text, Int)
go
 where
  go :: Ptr CharBufElem -> m (Text, Int)
go Ptr CharBufElem
pbuf = do
    let !t :: Text
t = Stream CharBufElem -> Text
unstream ((Int -> Step Int CharBufElem) -> Int -> Size -> Stream CharBufElem
forall a s. (s -> Step s a) -> s -> Size -> Stream a
Stream Int -> Step Int CharBufElem
next Int
r (Int -> Size
maxSize (Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
r)))
        w' :: Int
w' = Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    (Text, Int) -> m (Text, Int)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text, Int) -> m (Text, Int)) -> (Text, Int) -> m (Text, Int)
forall a b. (a -> b) -> a -> b
$ if Int -> CharBufElem
ix Int
w' CharBufElem -> CharBufElem -> Bool
forall a. Eq a => a -> a -> Bool
== CharBufElem
'\r'
             then (Text
t,Int
w')
             else (Text
t,Int
w)
   where
    next :: Int -> Step Int CharBufElem
next !Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
w = Step Int CharBufElem
forall s a. Step s a
Done
            | CharBufElem
c CharBufElem -> CharBufElem -> Bool
forall a. Eq a => a -> a -> Bool
== CharBufElem
'\r' = let i' :: Int
i' = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                          in if Int
i' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w
                             then if Int -> CharBufElem
ix Int
i' CharBufElem -> CharBufElem -> Bool
forall a. Eq a => a -> a -> Bool
== CharBufElem
'\n'
                                  then CharBufElem -> Int -> Step Int CharBufElem
forall s a. a -> s -> Step s a
Yield CharBufElem
'\n' (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)
                                  else CharBufElem -> Int -> Step Int CharBufElem
forall s a. a -> s -> Step s a
Yield CharBufElem
'\n' Int
i'
                             else Step Int CharBufElem
forall s a. Step s a
Done
            | Bool
otherwise = CharBufElem -> Int -> Step Int CharBufElem
forall s a. a -> s -> Step s a
Yield CharBufElem
c (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            where c :: CharBufElem
c = Int -> CharBufElem
ix Int
i
    ix :: Int -> CharBufElem
ix Int
i = IO CharBufElem -> CharBufElem
forall a. IO a -> a
inlinePerformIO (IO CharBufElem -> CharBufElem) -> IO CharBufElem -> CharBufElem
forall a b. (a -> b) -> a -> b
$ Ptr CharBufElem -> Int -> IO CharBufElem
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CharBufElem
pbuf Int
i

-- This function is completely lifted from GHC.IO.Handle.Text.
getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
getSomeCharacters :: Handle__ -> Buffer CharBufElem -> IO (Buffer CharBufElem)
getSomeCharacters handle_ :: Handle__
handle_@Handle__{dev
Maybe (MVar Handle__)
Maybe TextEncoding
Maybe (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
IORef (dec_state, Buffer Word8)
IORef (Buffer CharBufElem)
IORef (Buffer Word8)
IORef (BufferList CharBufElem)
Newline
BufferMode
HandleType
haOtherSide :: Handle__ -> Maybe (MVar Handle__)
haOutputNL :: Handle__ -> Newline
haInputNL :: Handle__ -> Newline
haCodec :: Handle__ -> Maybe TextEncoding
haDecoder :: ()
haEncoder :: ()
haBuffers :: Handle__ -> IORef (BufferList CharBufElem)
haCharBuffer :: Handle__ -> IORef (Buffer CharBufElem)
haLastDecode :: ()
haBufferMode :: Handle__ -> BufferMode
haByteBuffer :: Handle__ -> IORef (Buffer Word8)
haType :: Handle__ -> HandleType
haDevice :: ()
haDevice :: dev
haType :: HandleType
haByteBuffer :: IORef (Buffer Word8)
haBufferMode :: BufferMode
haLastDecode :: IORef (dec_state, Buffer Word8)
haCharBuffer :: IORef (Buffer CharBufElem)
haBuffers :: IORef (BufferList CharBufElem)
haEncoder :: Maybe (TextEncoder enc_state)
haDecoder :: Maybe (TextDecoder dec_state)
haCodec :: Maybe TextEncoding
haInputNL :: Newline
haOutputNL :: Newline
haOtherSide :: Maybe (MVar Handle__)
..} buf :: Buffer CharBufElem
buf@Buffer{Int
Word64
RawBuffer CharBufElem
BufferState
bufL :: forall e. Buffer e -> Int
bufR :: forall e. Buffer e -> Int
bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw :: RawBuffer CharBufElem
bufState :: BufferState
bufSize :: Int
bufOffset :: Word64
bufL :: Int
bufR :: Int
bufOffset :: forall e. Buffer e -> Word64
bufSize :: forall e. Buffer e -> Int
bufState :: forall e. Buffer e -> BufferState
..} =
  case Buffer CharBufElem -> Int
forall e. Buffer e -> Int
bufferElems Buffer CharBufElem
buf of
    -- buffer empty: read some more
    Int
0 -> {-# SCC "readTextDevice" #-} Handle__ -> Buffer CharBufElem -> IO (Buffer CharBufElem)
readTextDevice Handle__
handle_ Buffer CharBufElem
buf

    -- if the buffer has a single '\r' in it and we're doing newline
    -- translation: read some more
    Int
1 | Newline
haInputNL Newline -> Newline -> Bool
forall a. Eq a => a -> a -> Bool
== Newline
CRLF -> do
      (c,_) <- RawBuffer CharBufElem -> Int -> IO (CharBufElem, Int)
readCharBuf RawBuffer CharBufElem
bufRaw Int
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
                 _ <- writeCharBuf bufRaw 0 '\r'
                 let buf' = Buffer CharBufElem
buf{ bufL=0, bufR=1 }
                 readTextDevice handle_ buf'
         else do
                 return buf

    -- buffer has some chars in it already: just return it
    Int
_otherwise -> {-# SCC "otherwise" #-} Buffer CharBufElem -> IO (Buffer CharBufElem)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Buffer CharBufElem
buf

-- | Read a single chunk of strict text from a buffer. Used by both
-- the strict and lazy implementations of hGetContents.
readChunk :: Handle__ -> CharBuffer -> IO Text
readChunk :: Handle__ -> Buffer CharBufElem -> IO Text
readChunk hh :: Handle__
hh@Handle__{dev
Maybe (MVar Handle__)
Maybe TextEncoding
Maybe (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
IORef (dec_state, Buffer Word8)
IORef (Buffer CharBufElem)
IORef (Buffer Word8)
IORef (BufferList CharBufElem)
Newline
BufferMode
HandleType
haOtherSide :: Handle__ -> Maybe (MVar Handle__)
haOutputNL :: Handle__ -> Newline
haInputNL :: Handle__ -> Newline
haCodec :: Handle__ -> Maybe TextEncoding
haDecoder :: ()
haEncoder :: ()
haBuffers :: Handle__ -> IORef (BufferList CharBufElem)
haCharBuffer :: Handle__ -> IORef (Buffer CharBufElem)
haLastDecode :: ()
haBufferMode :: Handle__ -> BufferMode
haByteBuffer :: Handle__ -> IORef (Buffer Word8)
haType :: Handle__ -> HandleType
haDevice :: ()
haDevice :: dev
haType :: HandleType
haByteBuffer :: IORef (Buffer Word8)
haBufferMode :: BufferMode
haLastDecode :: IORef (dec_state, Buffer Word8)
haCharBuffer :: IORef (Buffer CharBufElem)
haBuffers :: IORef (BufferList CharBufElem)
haEncoder :: Maybe (TextEncoder enc_state)
haDecoder :: Maybe (TextDecoder dec_state)
haCodec :: Maybe TextEncoding
haInputNL :: Newline
haOutputNL :: Newline
haOtherSide :: Maybe (MVar Handle__)
..} Buffer CharBufElem
buf = do
  buf'@Buffer{..} <- Handle__ -> Buffer CharBufElem -> IO (Buffer CharBufElem)
getSomeCharacters Handle__
hh Buffer CharBufElem
buf
  (t,r) <- if haInputNL == CRLF
           then unpack_nl bufRaw bufL bufR
           else do t <- unpack bufRaw bufL bufR
                   return (t,bufR)
  writeIORef haCharBuffer (bufferAdjustL r buf')
  return t

-- | Print a @Stream Char@.
hPutStream :: Handle -> Stream Char -> IO ()
hPutStream :: Handle -> Stream CharBufElem -> IO ()
hPutStream Handle
h Stream CharBufElem
str = Handle -> Stream CharBufElem -> Maybe (IO ()) -> IO ()
hPutStreamOrUtf8 Handle
h Stream CharBufElem
str Maybe (IO ())
forall a. Maybe a
Nothing

-- | Write a string to a handle.
hPutStr :: Handle -> Text -> IO ()
hPutStr :: Handle -> Text -> IO ()
hPutStr Handle
h Text
t = Handle -> Stream CharBufElem -> Maybe (IO ()) -> IO ()
hPutStreamOrUtf8 Handle
h (Text -> Stream CharBufElem
stream Text
t) (IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just IO ()
putUtf8)
  where
    putUtf8 :: IO ()
putUtf8 = Handle -> ByteString -> IO ()
B.hPutStr Handle
h (Text -> ByteString
encodeUtf8 Text
t)

-- | Write a string to a handle, followed by a newline.
hPutStrLn :: Handle -> Text -> IO ()
hPutStrLn :: Handle -> Text -> IO ()
hPutStrLn Handle
h Text
t = Handle -> Stream CharBufElem -> Maybe (IO ()) -> IO ()
hPutStreamOrUtf8 Handle
h (Text -> Stream CharBufElem
streamLn Text
t) (IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just IO ()
putUtf8)
  where
    -- Not using B.hPutStrLn because it's not necessarily atomic:
    -- https://github.com/haskell/bytestring/issues/200
    putUtf8 :: IO ()
putUtf8 = Handle -> Builder -> IO ()
hPutBuilder Handle
h (Text -> Builder
encodeUtf8Builder Text
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> CharBufElem -> Builder
charUtf8 CharBufElem
'\n')

-- | 'hPutStream' with an optional special case when the output encoding is
-- UTF-8 and without newline conversion.
hPutStreamOrUtf8 :: Handle -> Stream Char -> Maybe (IO ()) -> IO ()
-- This function is modified from GHC.IO.Handle.Text.
hPutStreamOrUtf8 :: Handle -> Stream CharBufElem -> Maybe (IO ()) -> IO ()
hPutStreamOrUtf8 Handle
h Stream CharBufElem
str Maybe (IO ())
mPutUtf8 = do
  (buffer_mode, nl, isUtf8) <-
       String
-> Handle
-> (Handle__
    -> IO ((BufferMode, Buffer CharBufElem), Newline, Bool))
-> IO ((BufferMode, Buffer CharBufElem), Newline, Bool)
forall a. String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle String
"hPutStr" Handle
h ((Handle__ -> IO ((BufferMode, Buffer CharBufElem), Newline, Bool))
 -> IO ((BufferMode, Buffer CharBufElem), Newline, Bool))
-> (Handle__
    -> IO ((BufferMode, Buffer CharBufElem), Newline, Bool))
-> IO ((BufferMode, Buffer CharBufElem), Newline, Bool)
forall a b. (a -> b) -> a -> b
$ \Handle__
h_ -> do
                     bmode <- Handle__ -> IO (BufferMode, Buffer CharBufElem)
getSpareBuffer Handle__
h_
                     return (bmode, haOutputNL h_, eqUTF8 h_)
  case buffer_mode of
     (BufferMode, Buffer CharBufElem)
_ | Just IO ()
putUtf8 <- Maybe (IO ())
mPutUtf8, Newline
nl Newline -> Newline -> Bool
forall a. Eq a => a -> a -> Bool
== Newline
LF Bool -> Bool -> Bool
&& Bool
isUtf8 -> IO ()
putUtf8
     (BufferMode
NoBuffering, Buffer CharBufElem
_)        -> Handle -> Stream CharBufElem -> IO ()
hPutChars Handle
h Stream CharBufElem
str
     (BufferMode
LineBuffering, Buffer CharBufElem
buf)    -> Handle
-> Newline -> Buffer CharBufElem -> Stream CharBufElem -> IO ()
writeLines Handle
h Newline
nl Buffer CharBufElem
buf Stream CharBufElem
str
     (BlockBuffering Maybe Int
_, Buffer CharBufElem
buf) -> Bool -> Handle -> Buffer CharBufElem -> Stream CharBufElem -> IO ()
writeBlocks (Newline
nl Newline -> Newline -> Bool
forall a. Eq a => a -> a -> Bool
== Newline
CRLF) Handle
h Buffer CharBufElem
buf Stream CharBufElem
str

  where
  -- If the encoding is UTF-8, it's most likely pointer-equal to
  -- 'System.IO.utf8', letting us avoid a String comparison.
  -- If it is somehow UTF-8 but not pointer-equal to 'utf8',
  -- we will just take a slower branch, but the result is still correct.
  eqUTF8 :: Handle__ -> Bool
eqUTF8 = Bool -> (TextEncoding -> Bool) -> Maybe TextEncoding -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\TextEncoding
enc -> Int# -> Bool
isTrue# (TextEncoding -> TextEncoding -> Int#
forall a b. a -> b -> Int#
reallyUnsafePtrEquality# TextEncoding
utf8 TextEncoding
enc)) (Maybe TextEncoding -> Bool)
-> (Handle__ -> Maybe TextEncoding) -> Handle__ -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle__ -> Maybe TextEncoding
haCodec
{-# INLINE hPutStreamOrUtf8 #-}

hPutChars :: Handle -> Stream Char -> IO ()
hPutChars :: Handle -> Stream CharBufElem -> IO ()
hPutChars Handle
h (Stream s -> Step s CharBufElem
next0 s
s0 Size
_len) = s -> IO ()
loop s
s0
  where
    loop :: s -> IO ()
loop !s
s = case s -> Step s CharBufElem
next0 s
s of
                Step s CharBufElem
Done       -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Skip s
s'    -> s -> IO ()
loop s
s'
                Yield CharBufElem
x s
s' -> Handle -> CharBufElem -> IO ()
hPutChar Handle
h CharBufElem
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> s -> IO ()
loop s
s'

-- The following functions are largely lifted from GHC.IO.Handle.Text,
-- but adapted to a coinductive stream of data instead of an inductive
-- list.
--
-- We have several variations of more or less the same code for
-- performance reasons.  Splitting the original buffered write
-- function into line- and block-oriented versions gave us a 2.1x
-- performance improvement.  Lifting out the raw/cooked newline
-- handling gave a few more percent on top.

writeLines :: Handle -> Newline -> CharBuffer -> Stream Char -> IO ()
writeLines :: Handle
-> Newline -> Buffer CharBufElem -> Stream CharBufElem -> IO ()
writeLines Handle
h Newline
nl Buffer CharBufElem
buf0 (Stream s -> Step s CharBufElem
next0 s
s0 Size
_len) = s -> Buffer CharBufElem -> IO ()
outer s
s0 Buffer CharBufElem
buf0
 where
  outer :: s -> Buffer CharBufElem -> IO ()
outer s
s1 Buffer{bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer CharBufElem
raw, bufSize :: forall e. Buffer e -> Int
bufSize=Int
len} = s -> Int -> IO ()
inner s
s1 (Int
0::Int)
   where
    inner :: s -> Int -> IO ()
inner !s
s !Int
n =
      case s -> Step s CharBufElem
next0 s
s of
        Step s CharBufElem
Done -> Int -> Bool -> Bool -> IO (Buffer CharBufElem)
commit Int
n Bool
False{-no flush-} Bool
True{-release-} IO (Buffer CharBufElem) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Skip s
s' -> s -> Int -> IO ()
inner s
s' Int
n
        Yield CharBufElem
x s
s'
          | Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len -> Int -> Bool -> Bool -> IO (Buffer CharBufElem)
commit Int
n Bool
True{-needs flush-} Bool
False IO (Buffer CharBufElem) -> (Buffer CharBufElem -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Buffer CharBufElem -> IO ()
outer s
s
          | CharBufElem
x CharBufElem -> CharBufElem -> Bool
forall a. Eq a => a -> a -> Bool
== CharBufElem
'\n'    -> do
                   n' <- if Newline
nl Newline -> Newline -> Bool
forall a. Eq a => a -> a -> Bool
== Newline
CRLF
                         then do n1 <- RawBuffer CharBufElem -> Int -> Int -> CharBufElem -> IO Int
writeCharBuf' RawBuffer CharBufElem
raw Int
len Int
n CharBufElem
'\r'
                                 writeCharBuf' raw len n1 '\n'
                         else RawBuffer CharBufElem -> Int -> Int -> CharBufElem -> IO Int
writeCharBuf' RawBuffer CharBufElem
raw Int
len Int
n CharBufElem
x
                   commit n' True{-needs flush-} False >>= outer s'
          | Bool
otherwise    -> RawBuffer CharBufElem -> Int -> Int -> CharBufElem -> IO Int
writeCharBuf' RawBuffer CharBufElem
raw Int
len Int
n CharBufElem
x IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Int -> IO ()
inner s
s'
    commit :: Int -> Bool -> Bool -> IO (Buffer CharBufElem)
commit = Handle
-> RawBuffer CharBufElem
-> Int
-> Int
-> Bool
-> Bool
-> IO (Buffer CharBufElem)
commitBuffer Handle
h RawBuffer CharBufElem
raw Int
len

writeBlocks :: Bool -> Handle -> CharBuffer -> Stream Char -> IO ()
writeBlocks :: Bool -> Handle -> Buffer CharBufElem -> Stream CharBufElem -> IO ()
writeBlocks Bool
isCRLF Handle
h Buffer CharBufElem
buf0 (Stream s -> Step s CharBufElem
next0 s
s0 Size
_len) = s -> Buffer CharBufElem -> IO ()
outer s
s0 Buffer CharBufElem
buf0
 where
  outer :: s -> Buffer CharBufElem -> IO ()
outer s
s1 Buffer{bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer CharBufElem
raw, bufSize :: forall e. Buffer e -> Int
bufSize=Int
len} = s -> Int -> IO ()
inner s
s1 (Int
0::Int)
   where
    inner :: s -> Int -> IO ()
inner !s
s !Int
n =
      case s -> Step s CharBufElem
next0 s
s of
        Step s CharBufElem
Done -> Int -> Bool -> Bool -> IO (Buffer CharBufElem)
commit Int
n Bool
False{-no flush-} Bool
True{-release-} IO (Buffer CharBufElem) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Skip s
s' -> s -> Int -> IO ()
inner s
s' Int
n
        Yield CharBufElem
x s
s'
          | Bool
isCRLF Bool -> Bool -> Bool
&& CharBufElem
x CharBufElem -> CharBufElem -> Bool
forall a. Eq a => a -> a -> Bool
== CharBufElem
'\n' Bool -> Bool -> Bool
&& Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len -> do
              n1 <- RawBuffer CharBufElem -> Int -> Int -> CharBufElem -> IO Int
writeCharBuf' RawBuffer CharBufElem
raw Int
len Int
n CharBufElem
'\r'
              writeCharBuf' raw len n1 '\n' >>= inner s'
          | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len -> RawBuffer CharBufElem -> Int -> Int -> CharBufElem -> IO Int
writeCharBuf' RawBuffer CharBufElem
raw Int
len Int
n CharBufElem
x IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Int -> IO ()
inner s
s'
          | Bool
otherwise -> Int -> Bool -> Bool -> IO (Buffer CharBufElem)
commit Int
n Bool
True{-needs flush-} Bool
False IO (Buffer CharBufElem) -> (Buffer CharBufElem -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Buffer CharBufElem -> IO ()
outer s
s
    commit :: Int -> Bool -> Bool -> IO (Buffer CharBufElem)
commit = Handle
-> RawBuffer CharBufElem
-> Int
-> Int
-> Bool
-> Bool
-> IO (Buffer CharBufElem)
commitBuffer Handle
h RawBuffer CharBufElem
raw Int
len

-- | Only modifies the raw buffer and not the buffer attributes
writeCharBuf' :: RawCharBuffer -> Int -> Int -> Char -> IO Int
writeCharBuf' :: RawBuffer CharBufElem -> Int -> Int -> CharBufElem -> IO Int
writeCharBuf' RawBuffer CharBufElem
bufRaw Int
bufSize Int
n CharBufElem
c = Bool -> IO Int -> IO Int
forall a. (?callStack::CallStack) => Bool -> a -> a
E.assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bufSize) (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$
  RawBuffer CharBufElem -> Int -> CharBufElem -> IO Int
writeCharBuf RawBuffer CharBufElem
bufRaw Int
n CharBufElem
c

-- This function is completely lifted from GHC.IO.Handle.Text.
getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer CharBufElem)
getSpareBuffer Handle__{haCharBuffer :: Handle__ -> IORef (Buffer CharBufElem)
haCharBuffer=IORef (Buffer CharBufElem)
ref,
                        haBuffers :: Handle__ -> IORef (BufferList CharBufElem)
haBuffers=IORef (BufferList CharBufElem)
spare_ref,
                        haBufferMode :: Handle__ -> BufferMode
haBufferMode=BufferMode
mode}
 = do
   case BufferMode
mode of
     BufferMode
NoBuffering -> (BufferMode, Buffer CharBufElem)
-> IO (BufferMode, Buffer CharBufElem)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BufferMode
mode, String -> Buffer CharBufElem
forall a. (?callStack::CallStack) => String -> a
error String
"no buffer!")
     BufferMode
_ -> do
          bufs <- IORef (BufferList CharBufElem) -> IO (BufferList CharBufElem)
forall a. IORef a -> IO a
readIORef IORef (BufferList CharBufElem)
spare_ref
          buf  <- readIORef ref
          case bufs of
            BufferListCons RawBuffer CharBufElem
b BufferList CharBufElem
rest -> do
                IORef (BufferList CharBufElem) -> BufferList CharBufElem -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (BufferList CharBufElem)
spare_ref BufferList CharBufElem
rest
                (BufferMode, Buffer CharBufElem)
-> IO (BufferMode, Buffer CharBufElem)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( BufferMode
mode, RawBuffer CharBufElem -> Int -> BufferState -> Buffer CharBufElem
forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer RawBuffer CharBufElem
b (Buffer CharBufElem -> Int
forall e. Buffer e -> Int
bufSize Buffer CharBufElem
buf) BufferState
WriteBuffer)
            BufferList CharBufElem
BufferListNil -> do
                new_buf <- Int -> BufferState -> IO (Buffer CharBufElem)
newCharBuffer (Buffer CharBufElem -> Int
forall e. Buffer e -> Int
bufSize Buffer CharBufElem
buf) BufferState
WriteBuffer
                return (mode, new_buf)


-- This function is modified from GHC.Internal.IO.Handle.Text.
commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool
             -> IO CharBuffer
commitBuffer :: Handle
-> RawBuffer CharBufElem
-> Int
-> Int
-> Bool
-> Bool
-> IO (Buffer CharBufElem)
commitBuffer Handle
hdl !RawBuffer CharBufElem
raw !Int
sz !Int
count Bool
flush Bool
release =
  String
-> Handle
-> (Handle__ -> IO (Buffer CharBufElem))
-> IO (Buffer CharBufElem)
forall a. String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle String
"commitAndReleaseBuffer" Handle
hdl ((Handle__ -> IO (Buffer CharBufElem)) -> IO (Buffer CharBufElem))
-> (Handle__ -> IO (Buffer CharBufElem)) -> IO (Buffer CharBufElem)
forall a b. (a -> b) -> a -> b
$
     RawBuffer CharBufElem
-> Int
-> Int
-> Bool
-> Bool
-> Handle__
-> IO (Buffer CharBufElem)
commitBuffer' RawBuffer CharBufElem
raw Int
sz Int
count Bool
flush Bool
release
{-# INLINE commitBuffer #-}

sizeError :: String -> a
sizeError :: forall a. String -> a
sizeError String
loc = String -> a
forall a. (?callStack::CallStack) => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Data.Text.IO." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": bad internal buffer size"