module GHC.IO.Buffer (
Buffer(..), BufferState(..), CharBuffer, CharBufElem,
newByteBuffer,
newCharBuffer,
newBuffer,
emptyBuffer,
bufferRemove,
bufferAdd,
slideContents,
bufferAdjustL,
isEmptyBuffer,
isFullBuffer,
isFullCharBuffer,
isWriteBuffer,
bufferElems,
bufferAvailable,
summaryBuffer,
withBuffer,
withRawBuffer,
checkBuffer,
RawBuffer,
readWord8Buf,
writeWord8Buf,
RawCharBuffer,
peekCharBuf,
readCharBuf,
writeCharBuf,
readCharBufPtr,
writeCharBufPtr,
charSize,
) where
import GHC.Base
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
#define CHARBUF_UTF32
type RawBuffer e = ForeignPtr e
readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8
readWord8Buf arr ix = withForeignPtr arr $ \p -> peekByteOff p ix
writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf arr ix w = withForeignPtr arr $ \p -> pokeByteOff p ix w
#ifdef CHARBUF_UTF16
type CharBufElem = Word16
#else
type CharBufElem = Char
#endif
type RawCharBuffer = RawBuffer CharBufElem
peekCharBuf :: RawCharBuffer -> Int -> IO Char
peekCharBuf arr ix = withForeignPtr arr $ \p -> do
(c,_) <- readCharBufPtr p ix
return c
readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int)
readCharBuf arr ix = withForeignPtr arr $ \p -> readCharBufPtr p ix
writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int
writeCharBuf arr ix c = withForeignPtr arr $ \p -> writeCharBufPtr p ix c
readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int)
#ifdef 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 p ix = do c <- peekElemOff (castPtr p) ix; return (c, ix+1)
#endif
writeCharBufPtr :: Ptr CharBufElem -> Int -> Char -> IO Int
#ifdef 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 p ix ch = do pokeElemOff (castPtr p) ix ch; return (ix+1)
#endif
charSize :: Int
#ifdef CHARBUF_UTF16
charSize = 2
#else
charSize = 4
#endif
data Buffer e
= Buffer {
bufRaw :: !(RawBuffer e),
bufState :: BufferState,
bufSize :: !Int,
bufL :: !Int,
bufR :: !Int
}
#ifdef CHARBUF_UTF16
type CharBuffer = Buffer Word16
#else
type CharBuffer = Buffer Char
#endif
data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f
withRawBuffer :: RawBuffer e -> (Ptr e -> IO a) -> IO a
withRawBuffer raw f = withForeignPtr (castForeignPtr raw) f
isEmptyBuffer :: Buffer e -> Bool
isEmptyBuffer Buffer{ bufL=l, bufR=r } = l == r
isFullBuffer :: Buffer e -> Bool
isFullBuffer Buffer{ bufR=w, bufSize=s } = s == w
isFullCharBuffer :: Buffer e -> Bool
#ifdef CHARBUF_UTF16
isFullCharBuffer buf = bufferAvailable buf < 2
#else
isFullCharBuffer = isFullBuffer
#endif
isWriteBuffer :: Buffer e -> Bool
isWriteBuffer buf = case bufState buf of
WriteBuffer -> True
ReadBuffer -> False
bufferElems :: Buffer e -> Int
bufferElems Buffer{ bufR=w, bufL=r } = w r
bufferAvailable :: Buffer e -> Int
bufferAvailable Buffer{ bufR=w, bufSize=s } = s w
bufferRemove :: Int -> Buffer e -> Buffer e
bufferRemove i buf@Buffer{ bufL=r } = bufferAdjustL (r+i) buf
bufferAdjustL :: Int -> Buffer e -> Buffer e
bufferAdjustL l buf@Buffer{ bufR=w }
| l == w = buf{ bufL=0, bufR=0 }
| otherwise = buf{ bufL=l, bufR=w }
bufferAdd :: Int -> Buffer e -> Buffer e
bufferAdd i buf@Buffer{ bufR=w } = buf{ bufR=w+i }
emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer raw sz state =
Buffer{ bufRaw=raw, bufState=state, bufR=0, bufL=0, bufSize=sz }
newByteBuffer :: Int -> BufferState -> IO (Buffer Word8)
newByteBuffer c st = newBuffer c c st
newCharBuffer :: Int -> BufferState -> IO CharBuffer
newCharBuffer c st = newBuffer (c * charSize) c st
newBuffer :: Int -> Int -> BufferState -> IO (Buffer e)
newBuffer bytes sz state = do
fp <- mallocForeignPtrBytes bytes
return (emptyBuffer fp sz state)
slideContents :: Buffer Word8 -> IO (Buffer Word8)
slideContents buf@Buffer{ bufL=l, bufR=r, bufRaw=raw } = do
let elems = r l
withRawBuffer raw $ \p ->
do _ <- memcpy p (p `plusPtr` l) (fromIntegral elems)
return ()
return buf{ bufL=0, bufR=elems }
foreign import ccall unsafe "memcpy"
memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
summaryBuffer :: Buffer a -> String
summaryBuffer buf = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")"
checkBuffer :: Buffer a -> IO ()
checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } = do
check buf (
size > 0
&& r <= w
&& w <= size
&& ( r /= w || state == WriteBuffer || (r == 0 && w == 0) )
&& ( state /= WriteBuffer || w < size )
)
check :: Buffer a -> Bool -> IO ()
check _ True = return ()
check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf)
RetroSearch is an open source project built by @garambo | Open a GitHub Issue
Search and Browse the WWW like it's 1997 | Search results from DuckDuckGo
HTML:
3.2
| Encoding:
UTF-8
| Version:
0.7.4