{-# LANGUAGE Trustworthy, BangPatterns #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.Buffer
-- Copyright   :  (c) The University of Glasgow 2008
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- Buffers used in the IO system
--
-----------------------------------------------------------------------------

module GHC.IO.Buffer (
    -- * Buffers of any element
    Buffer(..), BufferState(..), CharBuffer, CharBufElem,

    -- ** Creation
    newByteBuffer,
    newCharBuffer,
    newBuffer,
    emptyBuffer,

    -- ** Insertion/removal
    bufferRemove,
    bufferAdd,
    slideContents,
    bufferAdjustL,

    -- ** Inspecting
    isEmptyBuffer,
    isFullBuffer,
    isFullCharBuffer,
    isWriteBuffer,
    bufferElems,
    bufferAvailable,
    summaryBuffer,

    -- ** Operating on the raw buffer as a Ptr
    withBuffer,
    withRawBuffer,

    -- ** Assertions
    checkBuffer,

    -- * Raw buffers
    RawBuffer,
    readWord8Buf,
    writeWord8Buf,
    RawCharBuffer,
    peekCharBuf,
    readCharBuf,
    writeCharBuf,
    readCharBufPtr,
    writeCharBufPtr,
    charSize,
 ) where

import GHC.Base
-- import GHC.IO
import GHC.Num
import GHC.Ptr
import GHC.Word
import GHC.Show
import GHC.Real
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Storable

-- Char buffers use either UTF-16 or UTF-32, with the endianness matching
-- the endianness of the host.
--
-- Invariants:
--   * a Char buffer consists of *valid* UTF-16 or UTF-32
--   * only whole characters: no partial surrogate pairs

#define CHARBUF_UTF32

-- #define CHARBUF_UTF16
--
-- NB. it won't work to just change this to CHARBUF_UTF16.  Some of
-- the code to make this work is there, and it has been tested with
-- the Iconv codec, but there are some pieces that are known to be
-- broken.  In particular, the built-in codecs
-- e.g. GHC.IO.Encoding.UTF{8,16,32} need to use isFullCharBuffer or
-- similar in place of the ow >= os comparisons.

-- ---------------------------------------------------------------------------
-- Raw blocks of data

type RawBuffer e = ForeignPtr e

readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8
readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8
readWord8Buf arr :: RawBuffer Word8
arr ix :: Int
ix = RawBuffer Word8 -> (Ptr Word8 -> IO Word8) -> IO Word8
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr RawBuffer Word8
arr ((Ptr Word8 -> IO Word8) -> IO Word8)
-> (Ptr Word8 -> IO Word8) -> IO Word8
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Word8
p -> Ptr Word8 -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
p Int
ix

writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf arr :: RawBuffer Word8
arr ix :: Int
ix w :: Word8
w = RawBuffer Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr RawBuffer Word8
arr ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Word8
p -> Ptr Word8 -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
p Int
ix Word8
w

#if defined(CHARBUF_UTF16)
type CharBufElem = Word16
#else
type CharBufElem = Char
#endif

type RawCharBuffer = RawBuffer CharBufElem

peekCharBuf :: RawCharBuffer -> Int -> IO Char
peekCharBuf :: RawCharBuffer -> Int -> IO Char
peekCharBuf arr :: RawCharBuffer
arr ix :: Int
ix = RawCharBuffer -> (Ptr Char -> IO Char) -> IO Char
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr RawCharBuffer
arr ((Ptr Char -> IO Char) -> IO Char)
-> (Ptr Char -> IO Char) -> IO Char
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Char
p -> do
                        (c :: Char
c,_) <- Ptr Char -> Int -> IO (Char, Int)
readCharBufPtr Ptr Char
p Int
ix
                        Char -> IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c

{-# INLINE readCharBuf #-}
readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int)
readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int)
readCharBuf arr :: RawCharBuffer
arr ix :: Int
ix = RawCharBuffer -> (Ptr Char -> IO (Char, Int)) -> IO (Char, Int)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr RawCharBuffer
arr ((Ptr Char -> IO (Char, Int)) -> IO (Char, Int))
-> (Ptr Char -> IO (Char, Int)) -> IO (Char, Int)
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Char
p -> Ptr Char -> Int -> IO (Char, Int)
readCharBufPtr Ptr Char
p Int
ix

{-# INLINE writeCharBuf #-}
writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int
writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int
writeCharBuf arr :: RawCharBuffer
arr ix :: Int
ix c :: Char
c = RawCharBuffer -> (Ptr Char -> IO Int) -> IO Int
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr RawCharBuffer
arr ((Ptr Char -> IO Int) -> IO Int) -> (Ptr Char -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Char
p -> Ptr Char -> Int -> Char -> IO Int
writeCharBufPtr Ptr Char
p Int
ix Char
c

{-# INLINE readCharBufPtr #-}
readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int)
#if defined(CHARBUF_UTF16)
readCharBufPtr p ix = do
  c1 <- peekElemOff p ix
  if (c1 < 0xd800 || c1 > 0xdbff)
     then return (chr (fromIntegral c1), ix+1)
     else do c2 <- peekElemOff p (ix+1)
             return (unsafeChr ((fromIntegral c1 - 0xd800)*0x400 +
                                (fromIntegral c2 - 0xdc00) + 0x10000), ix+2)
#else
readCharBufPtr :: Ptr Char -> Int -> IO (Char, Int)
readCharBufPtr p :: Ptr Char
p ix :: Int
ix = do Char
c <- Ptr Char -> Int -> IO Char
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff (Ptr Char -> Ptr Char
forall a b. Ptr a -> Ptr b
castPtr Ptr Char
p) Int
ix; (Char, Int) -> IO (Char, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
c, Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
#endif

{-# INLINE writeCharBufPtr #-}
writeCharBufPtr :: Ptr CharBufElem -> Int -> Char -> IO Int
#if defined(CHARBUF_UTF16)
writeCharBufPtr p ix ch
  | c < 0x10000 = do pokeElemOff p ix (fromIntegral c)
                     return (ix+1)
  | otherwise   = do let c' = c - 0x10000
                     pokeElemOff p ix (fromIntegral (c' `div` 0x400 + 0xd800))
                     pokeElemOff p (ix+1) (fromIntegral (c' `mod` 0x400 + 0xdc00))
                     return (ix+2)
  where
    c = ord ch
#else
writeCharBufPtr :: Ptr Char -> Int -> Char -> IO Int
writeCharBufPtr p :: Ptr Char
p ix :: Int
ix ch :: Char
ch = do Ptr Char -> Int -> Char -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff (Ptr Char -> Ptr Char
forall a b. Ptr a -> Ptr b
castPtr Ptr Char
p) Int
ix Char
ch; Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
#endif

charSize :: Int
#if defined(CHARBUF_UTF16)
charSize = 2
#else
charSize :: Int
charSize = 4
#endif

-- ---------------------------------------------------------------------------
-- Buffers

-- | A mutable array of bytes that can be passed to foreign functions.
--
-- The buffer is represented by a record, where the record contains
-- the raw buffer and the start/end points of the filled portion.  The
-- buffer contents itself is mutable, but the rest of the record is
-- immutable.  This is a slightly odd mix, but it turns out to be
-- quite practical: by making all the buffer metadata immutable, we
-- can have operations on buffer metadata outside of the IO monad.
--
-- The "live" elements of the buffer are those between the 'bufL' and
-- 'bufR' offsets.  In an empty buffer, 'bufL' is equal to 'bufR', but
-- they might not be zero: for example, the buffer might correspond to
-- a memory-mapped file and in which case 'bufL' will point to the
-- next location to be written, which is not necessarily the beginning
-- of the file.
data Buffer e
  = Buffer {
        Buffer e -> RawBuffer e
bufRaw   :: !(RawBuffer e),
        Buffer e -> BufferState
bufState :: BufferState,
        Buffer e -> Int
bufSize  :: !Int,          -- in elements, not bytes
        Buffer e -> Int
bufL     :: !Int,          -- offset of first item in the buffer
        Buffer e -> Int
bufR     :: !Int           -- offset of last item + 1
  }

#if defined(CHARBUF_UTF16)
type CharBuffer = Buffer Word16
#else
type CharBuffer = Buffer Char
#endif

data BufferState = ReadBuffer | WriteBuffer
  deriving Eq -- ^ @since 4.2.0.0

withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer{ bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer e
raw } f :: Ptr e -> IO a
f = RawBuffer e -> (Ptr e -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (RawBuffer e -> RawBuffer e
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr RawBuffer e
raw) Ptr e -> IO a
f

withRawBuffer :: RawBuffer e -> (Ptr e -> IO a) -> IO a
withRawBuffer :: RawBuffer e -> (Ptr e -> IO a) -> IO a
withRawBuffer raw :: RawBuffer e
raw f :: Ptr e -> IO a
f = RawBuffer e -> (Ptr e -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (RawBuffer e -> RawBuffer e
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr RawBuffer e
raw) Ptr e -> IO a
f

isEmptyBuffer :: Buffer e -> Bool
isEmptyBuffer :: Buffer e -> Bool
isEmptyBuffer Buffer{ bufL :: forall e. Buffer e -> Int
bufL=Int
l, bufR :: forall e. Buffer e -> Int
bufR=Int
r } = Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
r

isFullBuffer :: Buffer e -> Bool
isFullBuffer :: Buffer e -> Bool
isFullBuffer Buffer{ bufR :: forall e. Buffer e -> Int
bufR=Int
w, bufSize :: forall e. Buffer e -> Int
bufSize=Int
s } = Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
w

-- if a Char buffer does not have room for a surrogate pair, it is "full"
isFullCharBuffer :: Buffer e -> Bool
#if defined(CHARBUF_UTF16)
isFullCharBuffer buf = bufferAvailable buf < 2
#else
isFullCharBuffer :: Buffer e -> Bool
isFullCharBuffer = Buffer e -> Bool
forall e. Buffer e -> Bool
isFullBuffer
#endif

isWriteBuffer :: Buffer e -> Bool
isWriteBuffer :: Buffer e -> Bool
isWriteBuffer buf :: Buffer e
buf = case Buffer e -> BufferState
forall e. Buffer e -> BufferState
bufState Buffer e
buf of
                        WriteBuffer -> Bool
True
                        ReadBuffer  -> Bool
False

bufferElems :: Buffer e -> Int
bufferElems :: Buffer e -> Int
bufferElems Buffer{ bufR :: forall e. Buffer e -> Int
bufR=Int
w, bufL :: forall e. Buffer e -> Int
bufL=Int
r } = Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r

bufferAvailable :: Buffer e -> Int
bufferAvailable :: Buffer e -> Int
bufferAvailable Buffer{ bufR :: forall e. Buffer e -> Int
bufR=Int
w, bufSize :: forall e. Buffer e -> Int
bufSize=Int
s } = Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
w

bufferRemove :: Int -> Buffer e -> Buffer e
bufferRemove :: Int -> Buffer e -> Buffer e
bufferRemove i :: Int
i buf :: Buffer e
buf@Buffer{ bufL :: forall e. Buffer e -> Int
bufL=Int
r } = Int -> Buffer e -> Buffer e
forall e. Int -> Buffer e -> Buffer e
bufferAdjustL (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i) Buffer e
buf

bufferAdjustL :: Int -> Buffer e -> Buffer e
bufferAdjustL :: Int -> Buffer e -> Buffer e
bufferAdjustL l :: Int
l buf :: Buffer e
buf@Buffer{ bufR :: forall e. Buffer e -> Int
bufR=Int
w }
  | Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
w    = Buffer e
buf{ bufL :: Int
bufL=0, bufR :: Int
bufR=0 }
  | Bool
otherwise = Buffer e
buf{ bufL :: Int
bufL=Int
l, bufR :: Int
bufR=Int
w }

bufferAdd :: Int -> Buffer e -> Buffer e
bufferAdd :: Int -> Buffer e -> Buffer e
bufferAdd i :: Int
i buf :: Buffer e
buf@Buffer{ bufR :: forall e. Buffer e -> Int
bufR=Int
w } = Buffer e
buf{ bufR :: Int
bufR=Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i }

emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer raw :: RawBuffer e
raw sz :: Int
sz state :: BufferState
state =
  $WBuffer :: forall e.
RawBuffer e -> BufferState -> Int -> Int -> Int -> Buffer e
Buffer{ bufRaw :: RawBuffer e
bufRaw=RawBuffer e
raw, bufState :: BufferState
bufState=BufferState
state, bufR :: Int
bufR=0, bufL :: Int
bufL=0, bufSize :: Int
bufSize=Int
sz }

newByteBuffer :: Int -> BufferState -> IO (Buffer Word8)
newByteBuffer :: Int -> BufferState -> IO (Buffer Word8)
newByteBuffer c :: Int
c st :: BufferState
st = Int -> Int -> BufferState -> IO (Buffer Word8)
forall e. Int -> Int -> BufferState -> IO (Buffer e)
newBuffer Int
c Int
c BufferState
st

newCharBuffer :: Int -> BufferState -> IO CharBuffer
newCharBuffer :: Int -> BufferState -> IO CharBuffer
newCharBuffer c :: Int
c st :: BufferState
st = Int -> Int -> BufferState -> IO CharBuffer
forall e. Int -> Int -> BufferState -> IO (Buffer e)
newBuffer (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
charSize) Int
c BufferState
st

newBuffer :: Int -> Int -> BufferState -> IO (Buffer e)
newBuffer :: Int -> Int -> BufferState -> IO (Buffer e)
newBuffer bytes :: Int
bytes sz :: Int
sz state :: BufferState
state = do
  ForeignPtr e
fp <- Int -> IO (ForeignPtr e)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
bytes
  Buffer e -> IO (Buffer e)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr e -> Int -> BufferState -> Buffer e
forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer ForeignPtr e
fp Int
sz BufferState
state)

-- | slides the contents of the buffer to the beginning
slideContents :: Buffer Word8 -> IO (Buffer Word8)
slideContents :: Buffer Word8 -> IO (Buffer Word8)
slideContents buf :: Buffer Word8
buf@Buffer{ bufL :: forall e. Buffer e -> Int
bufL=Int
l, bufR :: forall e. Buffer e -> Int
bufR=Int
r, bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer Word8
raw } = do
  let elems :: Int
elems = Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l
  RawBuffer Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withRawBuffer RawBuffer Word8
raw ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Word8
p ->
      do Ptr Word8
_ <- Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)
forall a. Ptr a -> Ptr a -> CSize -> IO (Ptr a)
memmove Ptr Word8
p (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
l) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
elems)
         () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Buffer Word8 -> IO (Buffer Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return Buffer Word8
buf{ bufL :: Int
bufL=0, bufR :: Int
bufR=Int
elems }

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

summaryBuffer :: Buffer a -> String
summaryBuffer :: Buffer a -> String
summaryBuffer !Buffer a
buf  -- Strict => slightly better code
   = "buf" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Buffer a -> Int
forall e. Buffer e -> Int
bufSize Buffer a
buf) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Buffer a -> Int
forall e. Buffer e -> Int
bufL Buffer a
buf) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Buffer a -> Int
forall e. Buffer e -> Int
bufR Buffer a
buf) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"

-- INVARIANTS on Buffers:
--   * r <= w
--   * if r == w, and the buffer is for reading, then r == 0 && w == 0
--   * a write buffer is never full.  If an operation
--     fills up the buffer, it will always flush it before
--     returning.
--   * a read buffer may be full as a result of hLookAhead.  In normal
--     operation, a read buffer always has at least one character of space.

checkBuffer :: Buffer a -> IO ()
checkBuffer :: Buffer a -> IO ()
checkBuffer buf :: Buffer a
buf@Buffer{ bufState :: forall e. Buffer e -> BufferState
bufState = BufferState
state, bufL :: forall e. Buffer e -> Int
bufL=Int
r, bufR :: forall e. Buffer e -> Int
bufR=Int
w, bufSize :: forall e. Buffer e -> Int
bufSize=Int
size } = do
     Buffer a -> Bool -> IO ()
forall a. Buffer a -> Bool -> IO ()
check Buffer a
buf (
        Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
        Bool -> Bool -> Bool
&& Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
w
        Bool -> Bool -> Bool
&& Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
size
        Bool -> Bool -> Bool
&& ( Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
w Bool -> Bool -> Bool
|| BufferState
state BufferState -> BufferState -> Bool
forall a. Eq a => a -> a -> Bool
== BufferState
WriteBuffer Bool -> Bool -> Bool
|| (Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0) )
        Bool -> Bool -> Bool
&& ( BufferState
state BufferState -> BufferState -> Bool
forall a. Eq a => a -> a -> Bool
/= BufferState
WriteBuffer Bool -> Bool -> Bool
|| Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
size ) -- write buffer is never full
      )

check :: Buffer a -> Bool -> IO ()
check :: Buffer a -> Bool -> IO ()
check _   True  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check buf :: Buffer a
buf False = String -> IO ()
forall a. String -> a
errorWithoutStackTrace ("buffer invariant violation: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer a -> String
forall a. Buffer a -> String
summaryBuffer Buffer a
buf)