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