2 % (c) The University of Glasgow 2006
3 % (c) The University of Glasgow, 1997-2006
6 Buffers for scanning string input stored in external arrays.
9 {-# LANGUAGE BangPatterns #-}
10 {-# OPTIONS_GHC -O -funbox-strict-fields #-}
11 -- We always optimise this, otherwise performance of a non-optimised
12 -- compiler is severely affected
17 -- non-abstract for vs\/HaskellService
19 -- * Creation\/destruction
21 hGetStringBufferBlock,
31 -- * Moving and comparison
44 #include "HsVersions.h"
47 import FastString hiding ( buf )
52 import System.IO ( hGetBuf, hFileSize,IOMode(ReadMode), hClose
57 import System.IO ( openBinaryFile )
59 -- -----------------------------------------------------------------------------
60 -- The StringBuffer type
62 -- |A StringBuffer is an internal pointer to a sized chunk of bytes.
63 -- The bytes are intended to be *immutable*. There are pure
64 -- operations to read the contents of a StringBuffer.
66 -- A StringBuffer may have a finalizer, depending on how it was
71 buf :: {-# UNPACK #-} !(ForeignPtr Word8),
72 len :: {-# UNPACK #-} !Int, -- length
73 cur :: {-# UNPACK #-} !Int -- current pos
75 -- The buffer is assumed to be UTF-8 encoded, and furthermore
76 -- we add three '\0' bytes to the end as sentinels so that the
77 -- decoder doesn't have to check for overflow at every single byte
78 -- of a multibyte sequence.
80 instance Show StringBuffer where
81 showsPrec _ s = showString "<stringbuffer("
82 . shows (len s) . showString "," . shows (cur s)
85 -- -----------------------------------------------------------------------------
86 -- Creation / Destruction
88 hGetStringBuffer :: FilePath -> IO StringBuffer
89 hGetStringBuffer fname = do
90 h <- openBinaryFile fname ReadMode
92 let size = fromIntegral size_i
93 buf <- mallocForeignPtrArray (size+3)
94 withForeignPtr buf $ \ptr -> do
95 r <- if size == 0 then return 0 else hGetBuf h ptr size
98 then ioError (userError "short read of file")
99 else newUTF8StringBuffer buf ptr size
101 hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer
102 hGetStringBufferBlock handle wanted
103 = do size_i <- hFileSize handle
104 offset_i <- hTell handle
105 let size = min wanted (fromIntegral $ size_i-offset_i)
106 buf <- mallocForeignPtrArray (size+3)
107 withForeignPtr buf $ \ptr ->
108 do r <- if size == 0 then return 0 else hGetBuf handle ptr size
110 then ioError (userError $ "short read of file: "++show(r,size,size_i,handle))
111 else newUTF8StringBuffer buf ptr size
113 newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer
114 newUTF8StringBuffer buf ptr size = do
115 pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]
116 -- sentinels for UTF-8 decoding
118 sb0 = StringBuffer buf size 0
119 (first_char, sb1) = nextChar sb0
120 -- skip the byte-order mark if there is one (see #1744)
121 -- This is better than treating #FEFF as whitespace,
122 -- because that would mess up layout. We don't have a concept
123 -- of zero-width whitespace in Haskell: all whitespace codepoints
124 -- have a width of one column.
125 return (if first_char == '\xfeff' then sb1 else sb0)
127 appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer
128 appendStringBuffers sb1 sb2
129 = do newBuf <- mallocForeignPtrArray (size+3)
130 withForeignPtr newBuf $ \ptr ->
131 withForeignPtr (buf sb1) $ \sb1Ptr ->
132 withForeignPtr (buf sb2) $ \sb2Ptr ->
133 do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len
134 copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len
135 pokeArray (ptr `advancePtr` size) [0,0,0]
136 return (StringBuffer newBuf size 0)
137 where sb1_len = calcLen sb1
138 sb2_len = calcLen sb2
139 calcLen sb = len sb - cur sb
140 size = sb1_len + sb2_len
142 stringToStringBuffer :: String -> StringBuffer
143 stringToStringBuffer str =
145 let size = utf8EncodedLength str
146 buf <- mallocForeignPtrArray (size+3)
147 withForeignPtr buf $ \ptr -> do
148 utf8EncodeString ptr str
149 pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]
150 -- sentinels for UTF-8 decoding
151 return (StringBuffer buf size 0)
153 -- -----------------------------------------------------------------------------
156 -- Getting our fingers dirty a little here, but this is performance-critical
157 {-# INLINE nextChar #-}
158 nextChar :: StringBuffer -> (Char,StringBuffer)
159 nextChar (StringBuffer buf len (I# cur#)) =
161 withForeignPtr buf $ \(Ptr a#) -> do
162 case utf8DecodeChar# (a# `plusAddr#` cur#) of
164 let cur' = I# (b# `minusAddr#` a#) in
165 return (C# c#, StringBuffer buf len cur')
167 currentChar :: StringBuffer -> Char
168 currentChar = fst . nextChar
170 prevChar :: StringBuffer -> Char -> Char
171 prevChar (StringBuffer _ _ 0) deflt = deflt
172 prevChar (StringBuffer buf _ cur) _ =
174 withForeignPtr buf $ \p -> do
175 p' <- utf8PrevChar (p `plusPtr` cur)
176 return (fst (utf8DecodeChar p'))
178 -- -----------------------------------------------------------------------------
181 stepOn :: StringBuffer -> StringBuffer
182 stepOn s = snd (nextChar s)
184 offsetBytes :: Int -> StringBuffer -> StringBuffer
185 offsetBytes i s = s { cur = cur s + i }
187 byteDiff :: StringBuffer -> StringBuffer -> Int
188 byteDiff s1 s2 = cur s2 - cur s1
190 atEnd :: StringBuffer -> Bool
191 atEnd (StringBuffer _ l c) = l == c
193 -- -----------------------------------------------------------------------------
196 lexemeToString :: StringBuffer -> Int {-bytes-} -> String
197 lexemeToString _ 0 = ""
198 lexemeToString (StringBuffer buf _ cur) bytes =
200 withForeignPtr buf $ \ptr ->
201 utf8DecodeString (ptr `plusPtr` cur) bytes
203 lexemeToFastString :: StringBuffer -> Int {-bytes-} -> FastString
204 lexemeToFastString _ 0 = nilFS
205 lexemeToFastString (StringBuffer buf _ cur) len =
207 withForeignPtr buf $ \ptr ->
208 return $! mkFastStringBytes (ptr `plusPtr` cur) len
210 -- -----------------------------------------------------------------------------
211 -- Parsing integer strings in various bases
213 byteOff :: StringBuffer -> Int -> Char
214 byteOff (StringBuffer buf _ cur) i =
215 inlinePerformIO $ withForeignPtr buf $ \ptr -> do
216 -- return $! cBox (indexWord8OffFastPtrAsFastChar
217 -- (pUnbox ptr) (iUnbox (cur+i)))
219 -- w <- peek (ptr `plusPtr` (cur+i))
220 -- return (unsafeChr (fromIntegral (w::Word8)))
222 -- | XXX assumes ASCII digits only (by using byteOff)
223 parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer
224 parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int
225 = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let
226 --LOL, in implementations where the indexing needs slow unsafePerformIO,
227 --this is less (not more) efficient than using the IO monad explicitly
230 byteOff i = cBox (indexWord8OffFastPtrAsFastChar ptr' (iUnbox (cur + i)))
231 go i x | i == len = x
232 | otherwise = case byteOff i of
233 char -> go (i + 1) (x * radix + toInteger (char_to_int char))