ghc/compiler/utils/StringBuffer.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
   3 %
   4 \section{String buffers}
   5
   6 Buffers for scanning string input stored in external arrays.
   7
   8 \begin{code}
   9
  10 {-# OPTIONS -fvia-C #-}
  11
  12 module StringBuffer
  13        (
  14         StringBuffer,
  15
  16          -- creation/destruction
  17         hGetStringBuffer,     -- :: FilePath     -> IO StringBuffer
  18         stringToStringBuffer, -- :: String       -> IO StringBuffer
  19         freeStringBuffer,     -- :: StringBuffer -> IO ()
  20
  21          -- Lookup
  22         currentChar,      -- :: StringBuffer -> Char
  23         currentChar#,     -- :: StringBuffer -> Char#
  24         indexSBuffer,     -- :: StringBuffer -> Int -> Char
  25         indexSBuffer#,    -- :: StringBuffer -> Int# -> Char#
  26          -- relative lookup, i.e, currentChar = lookAhead 0
  27         lookAhead,        -- :: StringBuffer -> Int  -> Char
  28         lookAhead#,       -- :: StringBuffer -> Int# -> Char#
  29
  30         -- offsets
  31         currentIndex#,    -- :: StringBuffer -> Int#
  32         lexemeIndex,      -- :: StringBuffer -> Int#
  33
  34          -- moving the end point of the current lexeme.
  35         setCurrentPos#,   -- :: StringBuffer -> Int# -> StringBuffer
  36         incLexeme,        -- :: StringBuffer -> StringBuffer
  37         decLexeme,        -- :: StringBuffer -> StringBuffer
  38
  39          -- move the start and end lexeme pointer on by x units.
  40         stepOn,           -- :: StringBuffer -> StringBuffer
  41         stepOnBy#,        -- :: StringBuffer -> Int# -> StringBuffer
  42         stepOnTo#,        -- :: StringBuffer -> Int# -> StringBuffer
  43         stepOnUntil,      -- :: (Char -> Bool) -> StringBuffer -> StringBuffer
  44         stepOnUntilChar#, -- :: StringBuffer -> Char# -> StringBuffer
  45         stepOverLexeme,   -- :: StringBuffer   -> StringBuffer
  46         scanNumLit,       -- :: Int -> StringBuffer -> (Int, StringBuffer)
  47         squeezeLexeme,    -- :: StringBuffer -> Int# -> StringBuffer
  48         mergeLexemes,     -- :: StringBuffer -> StringBuffer -> StringBuffer
  49         expandWhile,      -- :: (Char  -> Bool) -> StringBuffer -> StringBuffer
  50         expandWhile#,     -- :: (Char# -> Bool) -> StringBuffer -> StringBuffer
  51         expandUntilMatch, -- :: StrinBuffer -> String -> StringBuffer
  52          -- at or beyond end of buffer?
  53         bufferExhausted,  -- :: StringBuffer -> Bool
  54         emptyLexeme,      -- :: StringBuffer -> Bool
  55
  56          -- matching
  57         prefixMatch,       -- :: StringBuffer -> String -> Bool
  58         untilEndOfString#, -- :: StringBuffer -> Int#
  59
  60          -- conversion
  61         lexemeToString,     -- :: StringBuffer -> String
  62         lexemeToByteArray,  -- :: StringBuffer -> _ByteArray Int
  63         lexemeToFastString, -- :: StringBuffer -> FastString
  64         lexemeToBuffer,     -- :: StringBuffer -> StringBuffer
  65
  66         FastString,
  67         ByteArray
  68        ) where
  69
  70 #include "HsVersions.h"
  71
  72 import GlaExts
  73 #if __GLASGOW_HASKELL__ < 411
  74 import PrelAddr         ( Addr(..) )
  75 #else
  76 import Addr             ( Addr(..) )
  77 #endif
  78 import Foreign
  79 import Char             ( chr )
  80 import Panic            ( panic )
  81
  82 import IO               ( openFile  )
  83 import IOExts           ( slurpFile )
  84 import PrelIOBase
  85 import PrelHandle
  86 import Addr
  87 #if __GLASGOW_HASKELL__ >= 411
  88 import Ptr              ( Ptr(..) )
  89 #endif
  90
  91 import PrelPack         ( unpackCStringBA )
  92
  93 #if __GLASGOW_HASKELL__ >= 501
  94 import PrelIO           ( hGetcBuffered )
  95 import PrelCError       ( throwErrnoIfMinus1RetryMayBlock )
  96 import PrelConc         ( threadWaitRead )
  97 #endif
  98
  99 import Exception        ( bracket )
 100 import PrimPacked
 101 import FastString
 102 import Char             ( isDigit )
 103 \end{code}
 104
 105 \begin{code}
 106 data StringBuffer
 107  = StringBuffer
 108      Addr#
 109      Int#         -- length
 110      Int#         -- lexeme start
 111      Int#         -- current pos
 112 \end{code}
 113
 114 \begin{code}
 115 instance Show StringBuffer where
 116         showsPrec _ s = showString ""
 117 \end{code}
 118
 119 \begin{code}
 120 hGetStringBuffer :: Bool -> FilePath -> IO StringBuffer
 121 hGetStringBuffer expand_tabs fname = do
 122    (a, read) <- if expand_tabs
 123                                 then slurpFileExpandTabs fname
 124 #if __GLASGOW_HASKELL__ < 411
 125                                 else slurpFile fname
 126 #else
 127                                 else do
 128                                     (Ptr a#, read) <- slurpFile fname
 129                                     return (A# a#, read)
 130 #endif
 131
 132    let (A# a#) = a;  (I# read#) = read
 133
 134          -- add sentinel '\NUL'
 135    _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' (A# a#) (I# (read# -# 1#))
 136    return (StringBuffer a# read# 0# 0#)
 137
 138 unsafeWriteBuffer :: StringBuffer -> Int# -> Char# -> StringBuffer
 139 unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# =
 140  unsafePerformIO (
 141    _casm_ `` ((char *)%0)[(int)%1]=(char)%2; '' (A# a) (I# i#) (C# ch#) >>= \ () ->
 142    return s
 143  )
 144 \end{code}
 145
 146 -----------------------------------------------------------------------------
 147 -- Turn a String into a StringBuffer
 148
 149 \begin{code}
 150 stringToStringBuffer :: String -> IO StringBuffer
 151 freeStringBuffer :: StringBuffer -> IO ()
 152
 153 #if __GLASGOW_HASKELL__ >= 411
 154 stringToStringBuffer str =
 155   do let sz@(I# sz#) = length str
 156      (Ptr a#) <- mallocBytes (sz+1)
 157      fill_in str (A# a#)
 158      writeCharOffAddr (A# a#) sz '\0'           -- sentinel
 159      return (StringBuffer a# sz# 0# 0#)
 160  where
 161   fill_in [] _ = return ()
 162   fill_in (c:cs) a = do
 163     writeCharOffAddr a 0 c
 164     fill_in cs (a `plusAddr` 1)
 165
 166 freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr a#)
 167 #else
 168 stringToStringBuffer = panic "stringToStringBuffer: not implemented"
 169 freeStringBuffer sb  = return ()
 170 #endif
 171
 172 \end{code}
 173
 174 -----------------------------------------------------------------------------
 175 This very disturbing bit of code is used for expanding the tabs in a
 176 file before we start parsing it.  Expanding the tabs early makes the
 177 lexer a lot simpler: we only have to record the beginning of the line
 178 in order to be able to calculate the column offset of the current
 179 token.
 180
 181 We guess the size of the buffer required as 20% extra for
 182 expanded tabs, and enlarge it if necessary.
 183
 184 \begin{code}
 185 getErrType :: IO Int
 186 getErrType =  _ccall_ getErrType__
 187
 188 slurpFileExpandTabs :: FilePath -> IO (Addr,Int)
 189 slurpFileExpandTabs fname = do
 190   bracket (openFile fname ReadMode) (hClose)
 191    (\ handle ->
 192      do sz <- hFileSize handle
 193         if sz > toInteger (maxBound::Int)
 194           then IOERROR (userError "slurpFile: file too big")
 195           else do
 196             let sz_i = fromInteger sz
 197                 sz_i' = (sz_i * 12) `div` 10            -- add 20% for tabs
 198             chunk <- allocMem sz_i'
 199             trySlurp handle sz_i' chunk
 200    )
 201
 202 trySlurp :: Handle -> Int -> Addr -> IO (Addr, Int)
 203 trySlurp handle sz_i chunk =
 204 #if __GLASGOW_HASKELL__ < 501
 205   wantReadableHandle "hGetChar" handle $ \ handle_ ->
 206   let fo = haFO__ handle_ in
 207 #else
 208   wantReadableHandle "hGetChar" handle $
 209       \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBufferMode=mode } ->
 210 #endif
 211   let
 212         (I# chunk_sz) = sz_i
 213
 214         tAB_SIZE = 8#
 215
 216         slurpFile :: Int# -> Int# -> Addr -> Int# -> Int# -> IO (Addr, Int)
 217         slurpFile c off chunk chunk_sz max_off = slurp c off
 218          where
 219
 220           slurp :: Int# -> Int# -> IO (Addr, Int)
 221           slurp c off | off >=# max_off = do
 222                 let new_sz = chunk_sz *# 2#
 223                 chunk' <- reAllocMem chunk (I# new_sz)
 224                 slurpFile c off chunk' new_sz (new_sz -# (tAB_SIZE +# 1#))
 225           slurp c off = do
 226 #if __GLASGOW_HASKELL__ < 501
 227                 intc <- mayBlock fo (_ccall_ fileGetc fo)
 228                 if intc == ((-1)::Int)
 229                   then do errtype <- getErrType
 230                           if errtype == (19{-ERR_EOF-} :: Int)
 231                             then return (chunk, I# off)
 232                             else constructErrorAndFail "slurpFile"
 233                   else case chr intc of
 234 #else
 235                 buf <- readIORef ref
 236                 ch <- (if not (bufferEmpty buf)
 237                       then hGetcBuffered fd ref buf
 238                       else do new_buf <- fillReadBuffer fd True buf
 239                               hGetcBuffered fd ref new_buf)
 240                     `catch` \e -> if isEOFError e
 241                         then return '\xFFFF'
 242                         else ioError e
 243                 case ch of
 244                          '\xFFFF' -> return (chunk, I# off)
 245 #endif
 246                          '\t' -> tabIt c off
 247                          ch   -> do  writeCharOffAddr chunk (I# off) ch
 248                                      let c' | ch == '\n' = 0#
 249                                             | otherwise  = c +# 1#
 250                                      slurp c' (off +# 1#)
 251
 252           tabIt :: Int# -> Int# -> IO (Addr, Int)
 253           -- can't run out of buffer in here, because we reserved an
 254           -- extra tAB_SIZE bytes at the end earlier.
 255           tabIt c off = do
 256                 writeCharOffAddr chunk (I# off) ' '
 257                 let c' = c +# 1#
 258                     off' = off +# 1#
 259                 if c' `remInt#` tAB_SIZE ==# 0#
 260                         then slurp c' off'
 261                         else tabIt c' off'
 262   in do
 263
 264         -- allow space for a full tab at the end of the buffer
 265         -- (that's what the max_off thing is for),
 266         -- and add 1 to allow room for the final sentinel \NUL at
 267         -- the end of the file.
 268   (chunk', rc) <- slurpFile 0# 0# chunk chunk_sz (chunk_sz -# (tAB_SIZE +# 1#))
 269 #if __GLASGOW_HASKELL__ < 404
 270   writeHandle handle handle_
 271 #endif
 272   return (chunk', rc+1 {-room for sentinel-})
 273
 274
 275 reAllocMem :: Addr -> Int -> IO Addr
 276 reAllocMem ptr sz = do
 277    chunk <- _ccall_ realloc ptr sz
 278    if chunk == nullAddr
 279       then fail "reAllocMem"
 280       else return chunk
 281
 282 allocMem :: Int -> IO Addr
 283 allocMem sz = do
 284    chunk <- _ccall_ malloc sz
 285    if chunk == nullAddr
 286 #if __GLASGOW_HASKELL__ < 501
 287       then constructErrorAndFail "allocMem"
 288 #else
 289       then ioException (IOError Nothing ResourceExhausted "malloc"
 290                                         "out of memory" Nothing)
 291 #endif
 292       else return chunk
 293 \end{code}
 294
 295 Lookup
 296
 297 \begin{code}
 298 currentChar  :: StringBuffer -> Char
 299 currentChar sb = case currentChar# sb of c -> C# c
 300
 301 lookAhead :: StringBuffer -> Int  -> Char
 302 lookAhead sb (I# i#) = case lookAhead# sb i# of c -> C# c
 303
 304 indexSBuffer :: StringBuffer -> Int -> Char
 305 indexSBuffer sb (I# i#) = case indexSBuffer# sb i# of c -> C# c
 306
 307 currentChar# :: StringBuffer -> Char#
 308 indexSBuffer# :: StringBuffer -> Int# -> Char#
 309 lookAhead# :: StringBuffer -> Int# -> Char#
 310 currentChar# (StringBuffer fo# _ _ current#) = indexCharOffAddr# fo# current#
 311 indexSBuffer# (StringBuffer fo# _ _ _) i# = indexCharOffAddr# fo# i#
 312
 313  -- relative lookup, i.e, currentChar = lookAhead 0
 314 lookAhead# (StringBuffer fo# _ _ c#) i# = indexCharOffAddr# fo# (c# +# i#)
 315
 316 currentIndex# :: StringBuffer -> Int#
 317 currentIndex# (StringBuffer fo# _ _ c#) = c#
 318
 319 lexemeIndex :: StringBuffer -> Int#
 320 lexemeIndex (StringBuffer fo# _ c# _) = c#
 321 \end{code}
 322
 323  moving the start point of the current lexeme.
 324
 325 \begin{code}
 326  -- moving the end point of the current lexeme.
 327 setCurrentPos# :: StringBuffer -> Int# -> StringBuffer
 328 setCurrentPos# (StringBuffer fo l# s# c#) i# =
 329  StringBuffer fo l# s# (c# +# i#)
 330
 331 -- augmenting the current lexeme by one.
 332 incLexeme :: StringBuffer -> StringBuffer
 333 incLexeme (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# +# 1#)
 334
 335 decLexeme :: StringBuffer -> StringBuffer
 336 decLexeme (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# -# 1#)
 337
 338 \end{code}
 339
 340 -- move the start and end point of the buffer on by
 341 -- x units.
 342
 343 \begin{code}
 344 stepOn :: StringBuffer -> StringBuffer
 345 stepOn (StringBuffer fo l# s# c#) = StringBuffer fo l# (s# +# 1#) (s# +# 1#) -- assume they're the same.
 346
 347 stepOnBy# :: StringBuffer -> Int# -> StringBuffer
 348 stepOnBy# (StringBuffer fo# l# s# c#) i# =
 349  case s# +# i# of
 350   new_s# -> StringBuffer fo# l# new_s# new_s#
 351
 352 -- jump to pos.
 353 stepOnTo# :: StringBuffer -> Int# -> StringBuffer
 354 stepOnTo# (StringBuffer fo l _ _) s# = StringBuffer fo l s# s#
 355
 356 squeezeLexeme :: StringBuffer -> Int# -> StringBuffer
 357 squeezeLexeme (StringBuffer fo l s# c#) i# = StringBuffer fo l (s# +# i#) c#
 358
 359 mergeLexemes :: StringBuffer -> StringBuffer -> StringBuffer
 360 mergeLexemes (StringBuffer fo l s# _) (StringBuffer _ _ _ c#)
 361    = StringBuffer fo l s# c#
 362
 363 stepOnUntil :: (Char -> Bool) -> StringBuffer -> StringBuffer
 364
 365 stepOnUntil pred (StringBuffer fo l# s# c#) =
 366  loop c#
 367   where
 368    loop c# =
 369     case indexCharOffAddr# fo c# of
 370      ch# | pred (C# ch#) -> StringBuffer fo l# c# c#
 371          | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# l# l# -- EOB, return immediately.
 372          | otherwise     -> loop (c# +# 1#)
 373
 374 stepOverLexeme :: StringBuffer -> StringBuffer
 375 stepOverLexeme (StringBuffer fo l s# c#) = StringBuffer fo l c# c#
 376
 377 expandWhile :: (Char -> Bool) -> StringBuffer -> StringBuffer
 378 expandWhile pred (StringBuffer fo l# s# c#) =
 379  loop c#
 380   where
 381    loop c# =
 382     case indexCharOffAddr# fo c# of
 383      ch# | pred (C# ch#) -> loop (c# +# 1#)
 384          | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# l# l# -- EOB, return immediately.
 385          | otherwise     -> StringBuffer fo l# s# c#
 386
 387 expandWhile# :: (Char# -> Bool) -> StringBuffer -> StringBuffer
 388 expandWhile# pred (StringBuffer fo l# s# c#) =
 389  loop c#
 390   where
 391    loop c# =
 392     case indexCharOffAddr# fo c# of
 393      ch# | pred ch# -> loop (c# +# 1#)
 394          | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# s# c# -- EOB, return immediately.
 395          | otherwise     -> StringBuffer fo l# s# c#
 396
 397 scanNumLit :: Integer -> StringBuffer -> (Integer,StringBuffer)
 398 scanNumLit acc (StringBuffer fo l# s# c#) =
 399  loop acc c#
 400   where
 401    loop acc c# =
 402     case indexCharOffAddr# fo c# of
 403      ch# | isDigit (C# ch#) -> loop (acc*10 + (toInteger (I# (ord# ch# -# ord# '0'#)))) (c# +# 1#)
 404          | ch# `eqChar#` '\NUL'# && c# >=# l# -> (acc, StringBuffer fo l# s# c#) -- EOB, return immediately.
 405          | otherwise        -> (acc,StringBuffer fo l# s# c#)
 406
 407
 408 expandUntilMatch :: StringBuffer -> String -> Maybe StringBuffer
 409 expandUntilMatch (StringBuffer fo l# s# c#) str =
 410   loop c# str
 411   where
 412    loop c# [] = Just (StringBuffer fo l# s# c#)
 413    loop c# ((C# x#):xs) =
 414     case indexCharOffAddr# fo c# of
 415       ch# | ch# `eqChar#` '\NUL'# && c# >=# l# -> Nothing
 416           | ch# `eqChar#` x# -> loop (c# +# 1#) xs
 417           | otherwise        -> loop (c# +# 1#) str
 418
 419 \end{code}
 420
 421 \begin{code}
 422    -- at or beyond end of buffer?
 423 bufferExhausted :: StringBuffer -> Bool
 424 bufferExhausted (StringBuffer fo l# _ c#) = c# >=# l#
 425
 426 emptyLexeme :: StringBuffer -> Bool
 427 emptyLexeme (StringBuffer fo l# s# c#) = s# ==# c#
 428
 429  -- matching
 430 prefixMatch :: StringBuffer -> String -> Maybe StringBuffer
 431 prefixMatch (StringBuffer fo l# s# c#) str =
 432   loop c# str
 433   where
 434    loop c# [] = Just (StringBuffer fo l# s# c#)
 435    loop c# ((C# x#):xs)
 436      | indexCharOffAddr# fo c# `eqChar#` x#
 437      = loop (c# +# 1#) xs
 438      | otherwise
 439      = Nothing
 440
 441 untilEndOfString# :: StringBuffer -> StringBuffer
 442 untilEndOfString# (StringBuffer fo l# s# c#) =
 443  loop c#
 444  where
 445   getch# i# = indexCharOffAddr# fo i#
 446
 447   loop c# =
 448    case getch# c# of
 449     '\"'# ->
 450       case getch# (c# -# 1#) of
 451         '\\'# ->
 452                   -- looks like an escaped something or other to me,
 453                   -- better count the number of "\\"s that are immediately
 454                   -- preceeding to decide if the " is escaped.
 455               let
 456                odd_slashes flg i# =
 457                 case getch# i# of
 458                  '\\'# -> odd_slashes (not flg) (i# -# 1#)
 459                  _     -> flg
 460               in
 461               if odd_slashes True (c# -# 2#) then
 462                   -- odd number, " is ecaped.
 463                   loop (c# +# 1#)
 464               else  -- a real end of string delimiter after all.
 465                   StringBuffer fo l# s# c#
 466         _ -> StringBuffer fo l# s# c#
 467     '\NUL'# ->
 468         if c# >=# l# then -- hit sentinel, this doesn't look too good..
 469            StringBuffer fo l# l# l#
 470         else
 471            loop (c# +# 1#)
 472     _ -> loop (c# +# 1#)
 473
 474
 475 stepOnUntilChar# :: StringBuffer -> Char# -> StringBuffer
 476 stepOnUntilChar# (StringBuffer fo l# s# c#) x# =
 477  loop c#
 478  where
 479   loop c#
 480    | c# >=# l# || indexCharOffAddr# fo c# `eqChar#` x#
 481    = StringBuffer fo l# c# c#
 482    | otherwise
 483    = loop (c# +# 1#)
 484
 485          -- conversion
 486 lexemeToString :: StringBuffer -> String
 487 lexemeToString (StringBuffer fo _ start_pos# current#) =
 488  if start_pos# ==# current# then
 489     ""
 490  else
 491     unpackCStringBA (copySubStr (A# fo) (I# start_pos#) (I# (current# -# start_pos#)))
 492
 493 lexemeToByteArray :: StringBuffer -> ByteArray Int
 494 lexemeToByteArray (StringBuffer fo _ start_pos# current#) =
 495  if start_pos# ==# current# then
 496     error "lexemeToByteArray"
 497  else
 498     copySubStr (A# fo) (I# start_pos#) (I# (current# -# start_pos#))
 499
 500 lexemeToFastString :: StringBuffer -> FastString
 501 lexemeToFastString (StringBuffer fo l# start_pos# current#) =
 502  if start_pos# ==# current# then
 503     mkFastCharString2 (A# fo) (I# 0#)
 504  else
 505     mkFastSubString (A# fo) (I# start_pos#) (I# (current# -# start_pos#))
 506
 507 {-
 508  Create a StringBuffer from the current lexeme, and add a sentinel
 509  at the end. Know What You're Doing before taking this function
 510  into use..
 511 -}
 512 lexemeToBuffer :: StringBuffer -> StringBuffer
 513 lexemeToBuffer (StringBuffer fo l# start_pos# current#) =
 514  if start_pos# ==# current# then
 515     StringBuffer fo 0# start_pos# current# -- an error, really.
 516  else
 517     unsafeWriteBuffer (StringBuffer fo (current# -# start_pos#) start_pos# start_pos#)
 518                       (current# -# 1#)
 519                       '\NUL'#
 520
 521 \end{code}