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