GHC 7.4 is now required for building HEAD
[ghc.git] / compiler / utils / StringBuffer.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The University of Glasgow, 1997-2006
4 %
5
6 Buffers for scanning string input stored in external arrays.
7
8 \begin{code}
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
13
14 module StringBuffer
15        (
16         StringBuffer(..),
17         -- non-abstract for vs\/HaskellService
18
19          -- * Creation\/destruction
20         hGetStringBuffer,
21         hGetStringBufferBlock,
22         appendStringBuffers,
23         stringToStringBuffer,
24
25         -- * Inspection
26         nextChar,
27         currentChar,
28         prevChar,
29         atEnd,
30
31         -- * Moving and comparison
32         stepOn,
33         offsetBytes,
34         byteDiff,
35
36         -- * Conversion
37         lexemeToString,
38         lexemeToFastString,
39
40          -- * Parsing integers
41         parseUnsignedInteger,
42        ) where
43
44 #include "HsVersions.h"
45
46 import Encoding
47 import FastString
48 import FastTypes
49 import FastFunctions
50
51 import System.IO                ( hGetBuf, hFileSize,IOMode(ReadMode), hClose
52                                 , Handle, hTell, openBinaryFile )
53 import System.IO.Unsafe         ( unsafePerformIO )
54
55 import GHC.Exts
56
57 import Foreign.Safe
58
59 -- -----------------------------------------------------------------------------
60 -- The StringBuffer type
61
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.
65 --
66 -- A StringBuffer may have a finalizer, depending on how it was
67 -- obtained.
68 --
69 data StringBuffer
70  = StringBuffer {
71      buf :: {-# UNPACK #-} !(ForeignPtr Word8),
72      len :: {-# UNPACK #-} !Int,        -- length
73      cur :: {-# UNPACK #-} !Int         -- current pos
74   }
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.
79
80 instance Show StringBuffer where
81         showsPrec _ s = showString "<stringbuffer("
82                       . shows (len s) . showString "," . shows (cur s)
83                       . showString ")>"
84
85 -- -----------------------------------------------------------------------------
86 -- Creation / Destruction
87
88 hGetStringBuffer :: FilePath -> IO StringBuffer
89 hGetStringBuffer fname = do
90    h <- openBinaryFile fname ReadMode
91    size_i <- hFileSize h
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
96      hClose h
97      if (r /= size)
98         then ioError (userError "short read of file")
99         else newUTF8StringBuffer buf ptr size
100
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
109                 if r /= size
110                    then ioError (userError $ "short read of file: "++show(r,size,size_i,handle))
111                    else newUTF8StringBuffer buf ptr size
112
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
117   let
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)
126
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
141
142 stringToStringBuffer :: String -> StringBuffer
143 stringToStringBuffer str =
144  unsafePerformIO $ do
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)
152
153 -- -----------------------------------------------------------------------------
154 -- Grab a character
155
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#)) =
160   inlinePerformIO $ do
161     withForeignPtr buf $ \(Ptr a#) -> do
162         case utf8DecodeChar# (a# `plusAddr#` cur#) of
163           (# c#, b# #) ->
164              let cur' = I# (b# `minusAddr#` a#) in
165              return (C# c#, StringBuffer buf len cur')
166
167 currentChar :: StringBuffer -> Char
168 currentChar = fst . nextChar
169
170 prevChar :: StringBuffer -> Char -> Char
171 prevChar (StringBuffer _   _   0)   deflt = deflt
172 prevChar (StringBuffer buf _   cur) _     =
173   inlinePerformIO $ do
174     withForeignPtr buf $ \p -> do
175       p' <- utf8PrevChar (p `plusPtr` cur)
176       return (fst (utf8DecodeChar p'))
177
178 -- -----------------------------------------------------------------------------
179 -- Moving
180
181 stepOn :: StringBuffer -> StringBuffer
182 stepOn s = snd (nextChar s)
183
184 offsetBytes :: Int -> StringBuffer -> StringBuffer
185 offsetBytes i s = s { cur = cur s + i }
186
187 byteDiff :: StringBuffer -> StringBuffer -> Int
188 byteDiff s1 s2 = cur s2 - cur s1
189
190 atEnd :: StringBuffer -> Bool
191 atEnd (StringBuffer _ l c) = l == c
192
193 -- -----------------------------------------------------------------------------
194 -- Conversion
195
196 lexemeToString :: StringBuffer -> Int {-bytes-} -> String
197 lexemeToString _ 0 = ""
198 lexemeToString (StringBuffer buf _ cur) bytes =
199   inlinePerformIO $
200     withForeignPtr buf $ \ptr ->
201       utf8DecodeString (ptr `plusPtr` cur) bytes
202
203 lexemeToFastString :: StringBuffer -> Int {-bytes-} -> FastString
204 lexemeToFastString _ 0 = nilFS
205 lexemeToFastString (StringBuffer buf _ cur) len =
206    inlinePerformIO $
207      withForeignPtr buf $ \ptr ->
208        return $! mkFastStringBytes (ptr `plusPtr` cur) len
209
210 -- -----------------------------------------------------------------------------
211 -- Parsing integer strings in various bases
212 {-
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)))
218 --or
219 --    w <- peek (ptr `plusPtr` (cur+i))
220 --    return (unsafeChr (fromIntegral (w::Word8)))
221 -}
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
228     --here.
229     !ptr' = pUnbox ptr
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))
234   in go 0 0
235
236 \end{code}