1 {-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
2 {-# OPTIONS_HADDOCK hide #-}
3 -----------------------------------------------------------------------------
5 -- Module : GHC.IO.Buffer
6 -- Copyright : (c) The University of Glasgow 2008
7 -- License : see libraries/base/LICENSE
9 -- Maintainer : cvs-ghc@haskell.org
10 -- Stability : internal
11 -- Portability : non-portable (GHC Extensions)
13 -- Buffers used in the IO system
15 -----------------------------------------------------------------------------
17 module GHC.IO.Buffer (
18 -- * Buffers of any element
19 Buffer(..), BufferState(..), CharBuffer, CharBufElem,
27 -- ** Insertion/removal
42 -- ** Operating on the raw buffer as a Ptr
69 import Foreign.C.Types
70 import Foreign.ForeignPtr
71 import Foreign.Storable
73 -- Char buffers use either UTF-16 or UTF-32, with the endianness matching
74 -- the endianness of the host.
77 -- * a Char buffer consists of *valid* UTF-16 or UTF-32
78 -- * only whole characters: no partial surrogate pairs
80 -- #define CHARBUF_UTF16
83 -- ---------------------------------------------------------------------------
86 type RawBuffer e = ForeignPtr e
88 readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8
89 readWord8Buf arr ix = withForeignPtr arr $ \p -> peekByteOff p ix
91 writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO ()
92 writeWord8Buf arr ix w = withForeignPtr arr $ \p -> pokeByteOff p ix w
95 type CharBufElem = Word16
97 type CharBufElem = Char
100 type RawCharBuffer = RawBuffer CharBufElem
102 peekCharBuf :: RawCharBuffer -> Int -> IO Char
103 peekCharBuf arr ix = withForeignPtr arr $ \p -> do
104 (c,_) <- readCharBufPtr p ix
107 {-# INLINE readCharBuf #-}
108 readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int)
109 readCharBuf arr ix = withForeignPtr arr $ \p -> readCharBufPtr p ix
111 {-# INLINE writeCharBuf #-}
112 writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int
113 writeCharBuf arr ix c = withForeignPtr arr $ \p -> writeCharBufPtr p ix c
115 {-# INLINE readCharBufPtr #-}
116 readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int)
118 readCharBufPtr p ix = do
119 c1 <- peekElemOff p ix
120 if (c1 < 0xd800 || c1 > 0xdbff)
121 then return (chr (fromIntegral c1), ix+1)
122 else do c2 <- peekElemOff p (ix+1)
123 return (unsafeChr ((fromIntegral c1 - 0xd800)*0x400 +
124 (fromIntegral c2 - 0xdc00) + 0x10000), ix+2)
126 readCharBufPtr p ix = do c <- peekElemOff (castPtr p) ix; return (c, ix+1)
129 {-# INLINE writeCharBufPtr #-}
130 writeCharBufPtr :: Ptr CharBufElem -> Int -> Char -> IO Int
132 writeCharBufPtr p ix ch
133 | c < 0x10000 = do pokeElemOff p ix (fromIntegral c)
135 | otherwise = do let c' = c - 0x10000
136 pokeElemOff p ix (fromIntegral (c' `div` 0x400 + 0xd800))
137 pokeElemOff p (ix+1) (fromIntegral (c' `mod` 0x400 + 0xdc00))
142 writeCharBufPtr p ix ch = do pokeElemOff (castPtr p) ix ch; return (ix+1)
152 -- ---------------------------------------------------------------------------
155 -- The buffer is represented by a mutable variable containing a
156 -- record, where the record contains the raw buffer and the start/end
157 -- points of the filled portion. We use a mutable variable so that
158 -- the common operation of writing (or reading) some data from (to)
159 -- the buffer doesn't need to modify, and hence copy, the handle
160 -- itself, it just updates the buffer.
162 -- There will be some allocation involved in a simple hPutChar in
163 -- order to create the new Buffer structure (below), but this is
164 -- relatively small, and this only has to be done once per write
167 -- | A mutable array of bytes that can be passed to foreign functions.
170 bufRaw :: !(RawBuffer e),
171 bufState :: BufferState,
172 bufSize :: !Int, -- in elements, not bytes
173 bufL :: !Int, -- offset of first item in the buffer
174 bufR :: !Int -- offset of last item + 1
178 type CharBuffer = Buffer Word16
180 type CharBuffer = Buffer Char
183 data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
185 withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a
186 withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f
188 withRawBuffer :: RawBuffer e -> (Ptr e -> IO a) -> IO a
189 withRawBuffer raw f = withForeignPtr (castForeignPtr raw) f
191 isEmptyBuffer :: Buffer e -> Bool
192 isEmptyBuffer Buffer{ bufR=w } = w == 0
194 isFullBuffer :: Buffer e -> Bool
195 isFullBuffer Buffer{ bufR=w, bufSize=s } = s == w
197 -- if a Char buffer does not have room for a surrogate pair, it is "full"
198 isFullCharBuffer :: Buffer e -> Bool
200 isFullCharBuffer buf = bufferAvailable buf < 2
202 isFullCharBuffer = isFullBuffer
205 isWriteBuffer :: Buffer e -> Bool
206 isWriteBuffer buf = case bufState buf of
210 bufferElems :: Buffer e -> Int
211 bufferElems Buffer{ bufR=w, bufL=r } = w - r
213 bufferAvailable :: Buffer e -> Int
214 bufferAvailable Buffer{ bufR=w, bufSize=s } = s - w
216 bufferRemove :: Int -> Buffer e -> Buffer e
217 bufferRemove i buf@Buffer{ bufL=r } = bufferAdjustL (r+i) buf
219 bufferAdjustL :: Int -> Buffer e -> Buffer e
220 bufferAdjustL l buf@Buffer{ bufR=w }
221 | l == w = buf{ bufL=0, bufR=0 }
222 | otherwise = buf{ bufL=l, bufR=w }
224 bufferAdd :: Int -> Buffer e -> Buffer e
225 bufferAdd i buf@Buffer{ bufR=w } = buf{ bufR=w+i }
227 emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e
228 emptyBuffer raw sz state =
229 Buffer{ bufRaw=raw, bufState=state, bufR=0, bufL=0, bufSize=sz }
231 newByteBuffer :: Int -> BufferState -> IO (Buffer Word8)
232 newByteBuffer c st = newBuffer c c st
234 newCharBuffer :: Int -> BufferState -> IO CharBuffer
235 newCharBuffer c st = newBuffer (c * charSize) c st
237 newBuffer :: Int -> Int -> BufferState -> IO (Buffer e)
238 newBuffer bytes sz state = do
239 fp <- mallocForeignPtrBytes bytes
240 return (emptyBuffer fp sz state)
242 -- | slides the contents of the buffer to the beginning
243 slideContents :: Buffer Word8 -> IO (Buffer Word8)
244 slideContents buf@Buffer{ bufL=l, bufR=r, bufRaw=raw } = do
246 withRawBuffer raw $ \p ->
247 do _ <- memcpy p (p `plusPtr` l) (fromIntegral elems)
249 return buf{ bufL=0, bufR=elems }
251 foreign import ccall unsafe "memcpy"
252 memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
254 summaryBuffer :: Buffer a -> String
255 summaryBuffer buf = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")"
257 -- INVARIANTS on Buffers:
259 -- * if r == w, then r == 0 && w == 0
260 -- * if state == WriteBuffer, then r == 0
261 -- * a write buffer is never full. If an operation
262 -- fills up the buffer, it will always flush it before
264 -- * a read buffer may be full as a result of hLookAhead. In normal
265 -- operation, a read buffer always has at least one character of space.
267 checkBuffer :: Buffer a -> IO ()
268 checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } = do
273 && ( r /= w || (r == 0 && w == 0) )
274 && ( state /= WriteBuffer || r == 0 )
275 && ( state /= WriteBuffer || w < size ) -- write buffer is never full
278 check :: Buffer a -> Bool -> IO ()
279 check _ True = return ()
280 check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf)