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 module StringBuffer
  10        (
  11         StringBuffer(..),
  12         -- non-abstract for vs\/HaskellService
  13
  14          -- * Creation\/destruction
  15         hGetStringBuffer,
  16         hGetStringBufferBlock,
  17         appendStringBuffers,
  18         stringToStringBuffer,
  19
  20         -- * Inspection
  21         nextChar,
  22         currentChar,
  23         prevChar,
  24         atEnd,
  25
  26         -- * Moving and comparison
  27         stepOn,
  28         offsetBytes,
  29         byteDiff,
  30
  31         -- * Conversion
  32         lexemeToString,
  33         lexemeToFastString,
  34
  35          -- * Parsing integers
  36         parseUnsignedInteger,
  37        ) where
  38
  39 #include "HsVersions.h"
  40
  41 import Encoding
  42 import FastString hiding ( buf )
  43 import FastTypes
  44 import FastFunctions
  45
  46 import Foreign
  47 import System.IO                ( hGetBuf, hFileSize,IOMode(ReadMode), hClose
  48                                 , Handle, hTell )
  49
  50 import GHC.Exts
  51
  52 import System.IO                ( openBinaryFile )
  53
  54 -- -----------------------------------------------------------------------------
  55 -- The StringBuffer type
  56
  57 -- |A StringBuffer is an internal pointer to a sized chunk of bytes.
  58 -- The bytes are intended to be *immutable*.  There are pure
  59 -- operations to read the contents of a StringBuffer.
  60 --
  61 -- A StringBuffer may have a finalizer, depending on how it was
  62 -- obtained.
  63 --
  64 data StringBuffer
  65  = StringBuffer {
  66      buf :: {-# UNPACK #-} !(ForeignPtr Word8),
  67      len :: {-# UNPACK #-} !Int,        -- length
  68      cur :: {-# UNPACK #-} !Int         -- current pos
  69   }
  70   -- The buffer is assumed to be UTF-8 encoded, and furthermore
  71   -- we add three '\0' bytes to the end as sentinels so that the
  72   -- decoder doesn't have to check for overflow at every single byte
  73   -- of a multibyte sequence.
  74
  75 instance Show StringBuffer where
  76         showsPrec _ s = showString "<stringbuffer("
  77                       . shows (len s) . showString "," . shows (cur s)
  78                       . showString ">"
  79
  80 -- -----------------------------------------------------------------------------
  81 -- Creation / Destruction
  82
  83 hGetStringBuffer :: FilePath -> IO StringBuffer
  84 hGetStringBuffer fname = do
  85    h <- openBinaryFile fname ReadMode
  86    size_i <- hFileSize h
  87    let size = fromIntegral size_i
  88    buf <- mallocForeignPtrArray (size+3)
  89    withForeignPtr buf $ \ptr -> do
  90      r <- if size == 0 then return 0 else hGetBuf h ptr size
  91      hClose h
  92      if (r /= size)
  93         then ioError (userError "short read of file")
  94         else newUTF8StringBuffer buf ptr size
  95
  96 hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer
  97 hGetStringBufferBlock handle wanted
  98     = do size_i <- hFileSize handle
  99          offset_i <- hTell handle
 100          let size = min wanted (fromIntegral $ size_i-offset_i)
 101          buf <- mallocForeignPtrArray (size+3)
 102          withForeignPtr buf $ \ptr ->
 103              do r <- if size == 0 then return 0 else hGetBuf handle ptr size
 104                 if r /= size
 105                    then ioError (userError $ "short read of file: "++show(r,size,size_i,handle))
 106                    else newUTF8StringBuffer buf ptr size
 107
 108 newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer
 109 newUTF8StringBuffer buf ptr size = do
 110   pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]
 111   -- sentinels for UTF-8 decoding
 112   let
 113       sb0 = StringBuffer buf size 0
 114       (first_char, sb1) = nextChar sb0
 115         -- skip the byte-order mark if there is one (see #1744)
 116         -- This is better than treating #FEFF as whitespace,
 117         -- because that would mess up layout.  We don't have a concept
 118         -- of zero-width whitespace in Haskell: all whitespace codepoints
 119         -- have a width of one column.
 120   return (if first_char == '\xfeff' then sb1 else sb0)
 121
 122 appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer
 123 appendStringBuffers sb1 sb2
 124     = do newBuf <- mallocForeignPtrArray (size+3)
 125          withForeignPtr newBuf $ \ptr ->
 126           withForeignPtr (buf sb1) $ \sb1Ptr ->
 127            withForeignPtr (buf sb2) $ \sb2Ptr ->
 128              do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len
 129                 copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len
 130                 pokeArray (ptr `advancePtr` size) [0,0,0]
 131                 return (StringBuffer newBuf size 0)
 132     where sb1_len = calcLen sb1
 133           sb2_len = calcLen sb2
 134           calcLen sb = len sb - cur sb
 135           size =  sb1_len + sb2_len
 136
 137 stringToStringBuffer :: String -> IO StringBuffer
 138 stringToStringBuffer str = do
 139   let size = utf8EncodedLength str
 140   buf <- mallocForeignPtrArray (size+3)
 141   withForeignPtr buf $ \ptr -> do
 142     utf8EncodeString ptr str
 143     pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]
 144     -- sentinels for UTF-8 decoding
 145   return (StringBuffer buf size 0)
 146
 147 -- -----------------------------------------------------------------------------
 148 -- Grab a character
 149
 150 -- Getting our fingers dirty a little here, but this is performance-critical
 151 {-# INLINE nextChar #-}
 152 nextChar :: StringBuffer -> (Char,StringBuffer)
 153 nextChar (StringBuffer buf len (I# cur#)) =
 154   inlinePerformIO $ do
 155     withForeignPtr buf $ \(Ptr a#) -> do
 156         case utf8DecodeChar# (a# `plusAddr#` cur#) of
 157           (# c#, b# #) ->
 158              let cur' = I# (b# `minusAddr#` a#) in
 159              return (C# c#, StringBuffer buf len cur')
 160
 161 currentChar :: StringBuffer -> Char
 162 currentChar = fst . nextChar
 163
 164 prevChar :: StringBuffer -> Char -> Char
 165 prevChar (StringBuffer _   _   0)   deflt = deflt
 166 prevChar (StringBuffer buf _   cur) _     =
 167   inlinePerformIO $ do
 168     withForeignPtr buf $ \p -> do
 169       p' <- utf8PrevChar (p `plusPtr` cur)
 170       return (fst (utf8DecodeChar p'))
 171
 172 -- -----------------------------------------------------------------------------
 173 -- Moving
 174
 175 stepOn :: StringBuffer -> StringBuffer
 176 stepOn s = snd (nextChar s)
 177
 178 offsetBytes :: Int -> StringBuffer -> StringBuffer
 179 offsetBytes i s = s { cur = cur s + i }
 180
 181 byteDiff :: StringBuffer -> StringBuffer -> Int
 182 byteDiff s1 s2 = cur s2 - cur s1
 183
 184 atEnd :: StringBuffer -> Bool
 185 atEnd (StringBuffer _ l c) = l == c
 186
 187 -- -----------------------------------------------------------------------------
 188 -- Conversion
 189
 190 lexemeToString :: StringBuffer -> Int {-bytes-} -> String
 191 lexemeToString _ 0 = ""
 192 lexemeToString (StringBuffer buf _ cur) bytes =
 193   inlinePerformIO $
 194     withForeignPtr buf $ \ptr ->
 195       utf8DecodeString (ptr `plusPtr` cur) bytes
 196
 197 lexemeToFastString :: StringBuffer -> Int {-bytes-} -> FastString
 198 lexemeToFastString _ 0 = nilFS
 199 lexemeToFastString (StringBuffer buf _ cur) len =
 200    inlinePerformIO $
 201      withForeignPtr buf $ \ptr ->
 202        return $! mkFastStringBytes (ptr `plusPtr` cur) len
 203
 204 -- -----------------------------------------------------------------------------
 205 -- Parsing integer strings in various bases
 206 {-
 207 byteOff :: StringBuffer -> Int -> Char
 208 byteOff (StringBuffer buf _ cur) i =
 209   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
 210 --    return $! cBox (indexWord8OffFastPtrAsFastChar
 211 --                         (pUnbox ptr) (iUnbox (cur+i)))
 212 --or
 213 --    w <- peek (ptr `plusPtr` (cur+i))
 214 --    return (unsafeChr (fromIntegral (w::Word8)))
 215 -}
 216 -- | XXX assumes ASCII digits only (by using byteOff)
 217 parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer
 218 parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int
 219   = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let
 220     --LOL, in implementations where the indexing needs slow unsafePerformIO,
 221     --this is less (not more) efficient than using the IO monad explicitly
 222     --here.
 223     ptr' = pUnbox ptr
 224     byteOff i = cBox (indexWord8OffFastPtrAsFastChar ptr' (iUnbox (cur + i)))
 225     go i x | i == len  = x
 226            | otherwise = case byteOff i of
 227                char -> go (i + 1) (x * radix + toInteger (char_to_int char))
 228   in go 0 0
 229
 230 \end{code}