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 mayBlock fo thing = thing
 186
 187 writeCharOffAddr :: Addr -> Int -> Char -> IO ()
 188 writeCharOffAddr addr off c
 189   = _casm_ ``*((char *)%0+(int)%1)=(char)%2;'' addr off c
 190 #endif
 191
 192 getErrType :: IO Int
 193 #if __GLASGOW_HASKELL__ < 303
 194 getErrType = _casm_ ``%r = ghc_errtype;''
 195 #else
 196 getErrType =  _ccall_ getErrType__
 197 #endif
 198
 199 slurpFileExpandTabs :: FilePath -> IO (Addr,Int)
 200 slurpFileExpandTabs fname = do
 201   bracket (openFile fname ReadMode) (hClose)
 202    (\ handle ->
 203      do sz <- hFileSize handle
 204         if sz > toInteger (maxBound::Int)
 205           then IOERROR (userError "slurpFile: file too big")
 206           else do
 207             let sz_i = fromInteger sz
 208                 sz_i' = (sz_i * 12) `div` 10            -- add 20% for tabs
 209             chunk <- allocMem sz_i'
 210             trySlurp handle sz_i' chunk
 211    )
 212
 213 trySlurp :: Handle -> Int -> Addr -> IO (Addr, Int)
 214 trySlurp handle sz_i chunk =
 215 #if __GLASGOW_HASKELL__ >= 303
 216   wantReadableHandle "hGetChar" handle $ \ handle_ ->
 217   let fo = haFO__ handle_ in
 218 #else
 219   readHandle handle        >>= \ handle_ ->
 220   let fo = filePtr handle_ in
 221 #endif
 222   let
 223         (I# chunk_sz) = sz_i
 224
 225         tAB_SIZE = 8#
 226
 227         slurpFile :: Int# -> Int# -> Addr -> Int# -> Int# -> IO (Addr, Int)
 228         slurpFile c off chunk chunk_sz max_off = slurp c off
 229          where
 230
 231           slurp :: Int# -> Int# -> IO (Addr, Int)
 232           slurp c off | off >=# max_off = do
 233                 let new_sz = chunk_sz *# 2#
 234                 chunk' <- reAllocMem chunk (I# new_sz)
 235                 slurpFile c off chunk' new_sz (new_sz -# (tAB_SIZE +# 1#))
 236           slurp c off = do
 237                 intc <- mayBlock fo (_ccall_ fileGetc fo)
 238                 if intc == ((-1)::Int)
 239                   then do errtype <- getErrType
 240                           if errtype == (ERR_EOF :: Int)
 241                             then return (chunk, I# off)
 242                             else constructErrorAndFail "slurpFile"
 243                   else case chr intc of
 244                          '\t' -> tabIt c off
 245                          ch   -> do  writeCharOffAddr chunk (I# off) ch
 246                                      let c' | ch == '\n' = 0#
 247                                             | otherwise  = c +# 1#
 248                                      slurp c' (off +# 1#)
 249
 250           tabIt :: Int# -> Int# -> IO (Addr, Int)
 251           -- can't run out of buffer in here, because we reserved an
 252           -- extra tAB_SIZE bytes at the end earlier.
 253           tabIt c off = do
 254                 writeCharOffAddr chunk (I# off) ' '
 255                 let c' = c +# 1#
 256                     off' = off +# 1#
 257                 if c' `remInt#` tAB_SIZE ==# 0#
 258                         then slurp c' off'
 259                         else tabIt c' off'
 260   in do
 261
 262         -- allow space for a full tab at the end of the buffer
 263         -- (that's what the max_off thing is for),
 264         -- and add 1 to allow room for the final sentinel \NUL at
 265         -- the end of the file.
 266   (chunk', rc) <- slurpFile 0# 0# chunk chunk_sz (chunk_sz -# (tAB_SIZE +# 1#))
 267 #if __GLASGOW_HASKELL__ < 404
 268   writeHandle handle handle_
 269 #endif
 270   if rc < (0::Int)
 271         then constructErrorAndFail "slurpFile"
 272         else 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 #if __GLASGOW_HASKELL__ < 303
 280       then fail (userError "reAllocMem")
 281 #else
 282       then fail "reAllocMem"
 283 #endif
 284       else return chunk
 285
 286 allocMem :: Int -> IO Addr
 287 allocMem sz = do
 288 #if __GLASGOW_HASKELL__ < 303
 289    chunk <- _ccall_ malloc sz
 290    if chunk == nullAddr
 291       then fail (userError "allocMem")
 292       else return chunk
 293 #else
 294    chunk <- _ccall_ allocMemory__ sz
 295    if chunk == nullAddr
 296       then constructErrorAndFail "allocMem"
 297       else return chunk
 298 #endif
 299 \end{code}
 300
 301 Lookup
 302
 303 \begin{code}
 304 currentChar  :: StringBuffer -> Char
 305 currentChar sb = case currentChar# sb of c -> C# c
 306
 307 lookAhead :: StringBuffer -> Int  -> Char
 308 lookAhead sb (I# i#) = case lookAhead# sb i# of c -> C# c
 309
 310 indexSBuffer :: StringBuffer -> Int -> Char
 311 indexSBuffer sb (I# i#) = case indexSBuffer# sb i# of c -> C# c
 312
 313 currentChar# :: StringBuffer -> Char#
 314 indexSBuffer# :: StringBuffer -> Int# -> Char#
 315 lookAhead# :: StringBuffer -> Int# -> Char#
 316 currentChar# (StringBuffer fo# _ _ current#) = indexCharOffAddr# fo# current#
 317 indexSBuffer# (StringBuffer fo# _ _ _) i# = indexCharOffAddr# fo# i#
 318
 319  -- relative lookup, i.e, currentChar = lookAhead 0
 320 lookAhead# (StringBuffer fo# _ _ c#) i# = indexCharOffAddr# fo# (c# +# i#)
 321
 322 currentIndex# :: StringBuffer -> Int#
 323 currentIndex# (StringBuffer fo# _ _ c#) = c#
 324
 325 lexemeIndex :: StringBuffer -> Int#
 326 lexemeIndex (StringBuffer fo# _ c# _) = c#
 327 \end{code}
 328
 329  moving the start point of the current lexeme.
 330
 331 \begin{code}
 332  -- moving the end point of the current lexeme.
 333 setCurrentPos# :: StringBuffer -> Int# -> StringBuffer
 334 setCurrentPos# (StringBuffer fo l# s# c#) i# =
 335  StringBuffer fo l# s# (c# +# i#)
 336
 337 -- augmenting the current lexeme by one.
 338 incLexeme :: StringBuffer -> StringBuffer
 339 incLexeme (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# +# 1#)
 340
 341 decLexeme :: StringBuffer -> StringBuffer
 342 decLexeme (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# -# 1#)
 343
 344 \end{code}
 345
 346 -- move the start and end point of the buffer on by
 347 -- x units.
 348
 349 \begin{code}
 350 stepOn :: StringBuffer -> StringBuffer
 351 stepOn (StringBuffer fo l# s# c#) = StringBuffer fo l# (s# +# 1#) (s# +# 1#) -- assume they're the same.
 352
 353 stepOnBy# :: StringBuffer -> Int# -> StringBuffer
 354 stepOnBy# (StringBuffer fo# l# s# c#) i# =
 355  case s# +# i# of
 356   new_s# -> StringBuffer fo# l# new_s# new_s#
 357
 358 -- jump to pos.
 359 stepOnTo# :: StringBuffer -> Int# -> StringBuffer
 360 stepOnTo# (StringBuffer fo l _ _) s# = StringBuffer fo l s# s#
 361
 362 squeezeLexeme :: StringBuffer -> Int# -> StringBuffer
 363 squeezeLexeme (StringBuffer fo l s# c#) i# = StringBuffer fo l (s# +# i#) c#
 364
 365 mergeLexemes :: StringBuffer -> StringBuffer -> StringBuffer
 366 mergeLexemes (StringBuffer fo l s# _) (StringBuffer _ _ _ c#)
 367    = StringBuffer fo l s# c#
 368
 369 stepOnUntil :: (Char -> Bool) -> StringBuffer -> StringBuffer
 370
 371 stepOnUntil pred (StringBuffer fo l# s# c#) =
 372  loop c#
 373   where
 374    loop c# =
 375     case indexCharOffAddr# fo c# of
 376      ch# | pred (C# ch#) -> StringBuffer fo l# c# c#
 377          | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# l# l# -- EOB, return immediately.
 378          | otherwise     -> loop (c# +# 1#)
 379
 380 stepOverLexeme :: StringBuffer -> StringBuffer
 381 stepOverLexeme (StringBuffer fo l s# c#) = StringBuffer fo l c# c#
 382
 383 expandWhile :: (Char -> Bool) -> StringBuffer -> StringBuffer
 384 expandWhile pred (StringBuffer fo l# s# c#) =
 385  loop c#
 386   where
 387    loop c# =
 388     case indexCharOffAddr# fo c# of
 389      ch# | pred (C# ch#) -> loop (c# +# 1#)
 390          | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# l# l# -- EOB, return immediately.
 391          | otherwise     -> StringBuffer fo l# s# c#
 392
 393 expandWhile# :: (Char# -> Bool) -> StringBuffer -> StringBuffer
 394 expandWhile# pred (StringBuffer fo l# s# c#) =
 395  loop c#
 396   where
 397    loop c# =
 398     case indexCharOffAddr# fo c# of
 399      ch# | pred ch# -> loop (c# +# 1#)
 400          | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# s# c# -- EOB, return immediately.
 401          | otherwise     -> StringBuffer fo l# s# c#
 402
 403 scanNumLit :: Integer -> StringBuffer -> (Integer,StringBuffer)
 404 scanNumLit acc (StringBuffer fo l# s# c#) =
 405  loop acc c#
 406   where
 407    loop acc c# =
 408     case indexCharOffAddr# fo c# of
 409      ch# | isDigit (C# ch#) -> loop (acc*10 + (toInteger (I# (ord# ch# -# ord# '0'#)))) (c# +# 1#)
 410          | ch# `eqChar#` '\NUL'# && c# >=# l# -> (acc, StringBuffer fo l# s# c#) -- EOB, return immediately.
 411          | otherwise        -> (acc,StringBuffer fo l# s# c#)
 412
 413
 414 expandUntilMatch :: StringBuffer -> String -> StringBuffer
 415 expandUntilMatch (StringBuffer fo l# s# c#) str =
 416   loop c# str
 417   where
 418    loop c# [] = StringBuffer fo l# s# c#
 419    loop c# ((C# x#):xs)
 420       | indexCharOffAddr# fo c# `eqChar#` x#
 421       = loop (c# +# 1#) xs
 422       | otherwise
 423       = loop (c# +# 1#) str
 424
 425 \end{code}
 426
 427 \begin{code}
 428    -- at or beyond end of buffer?
 429 bufferExhausted :: StringBuffer -> Bool
 430 bufferExhausted (StringBuffer fo l# _ c#) = c# >=# l#
 431
 432 emptyLexeme :: StringBuffer -> Bool
 433 emptyLexeme (StringBuffer fo l# s# c#) = s# ==# c#
 434
 435  -- matching
 436 prefixMatch :: StringBuffer -> String -> Maybe StringBuffer
 437 prefixMatch (StringBuffer fo l# s# c#) str =
 438   loop c# str
 439   where
 440    loop c# [] = Just (StringBuffer fo l# s# c#)
 441    loop c# ((C# x#):xs)
 442      | indexCharOffAddr# fo c# `eqChar#` x#
 443      = loop (c# +# 1#) xs
 444      | otherwise
 445      = Nothing
 446
 447 untilEndOfString# :: StringBuffer -> StringBuffer
 448 untilEndOfString# (StringBuffer fo l# s# c#) =
 449  loop c#
 450  where
 451   getch# i# = indexCharOffAddr# fo i#
 452
 453   loop c# =
 454    case getch# c# of
 455     '\"'# ->
 456       case getch# (c# -# 1#) of
 457         '\\'# ->
 458                   -- looks like an escaped something or other to me,
 459                   -- better count the number of "\\"s that are immediately
 460                   -- preceeding to decide if the " is escaped.
 461               let
 462                odd_slashes flg i# =
 463                 case getch# i# of
 464                  '\\'# -> odd_slashes (not flg) (i# -# 1#)
 465                  _     -> flg
 466               in
 467               if odd_slashes True (c# -# 2#) then
 468                   -- odd number, " is ecaped.
 469                   loop (c# +# 1#)
 470               else  -- a real end of string delimiter after all.
 471                   StringBuffer fo l# s# c#
 472         _ -> StringBuffer fo l# s# c#
 473     '\NUL'# ->
 474         if c# >=# l# then -- hit sentinel, this doesn't look too good..
 475            StringBuffer fo l# l# l#
 476         else
 477            loop (c# +# 1#)
 478     _ -> loop (c# +# 1#)
 479
 480
 481 untilChar# :: StringBuffer -> Char# -> StringBuffer
 482 untilChar# (StringBuffer fo l# s# c#) x# =
 483  loop c#
 484  where
 485   loop c#
 486    | c# >=# l# || indexCharOffAddr# fo c# `eqChar#` x#
 487    = StringBuffer fo l# s# c#
 488    | otherwise
 489    = loop (c# +# 1#)
 490
 491          -- conversion
 492 lexemeToString :: StringBuffer -> String
 493 lexemeToString (StringBuffer fo _ start_pos# current#) =
 494  if start_pos# ==# current# then
 495     ""
 496  else
 497     unpackCStringBA (copySubStr (A# fo) (I# start_pos#) (I# (current# -# start_pos#)))
 498
 499 lexemeToByteArray :: StringBuffer -> _ByteArray Int
 500 lexemeToByteArray (StringBuffer fo _ start_pos# current#) =
 501  if start_pos# ==# current# then
 502     error "lexemeToByteArray"
 503  else
 504     copySubStr (A# fo) (I# start_pos#) (I# (current# -# start_pos#))
 505
 506 lexemeToFastString :: StringBuffer -> FastString
 507 lexemeToFastString (StringBuffer fo l# start_pos# current#) =
 508  if start_pos# ==# current# then
 509     mkFastCharString2 (A# fo) (I# 0#)
 510  else
 511     mkFastSubString (A# fo) (I# start_pos#) (I# (current# -# start_pos#))
 512
 513 {-
 514  Create a StringBuffer from the current lexeme, and add a sentinel
 515  at the end. Know What You're Doing before taking this function
 516  into use..
 517 -}
 518 lexemeToBuffer :: StringBuffer -> StringBuffer
 519 lexemeToBuffer (StringBuffer fo l# start_pos# current#) =
 520  if start_pos# ==# current# then
 521     StringBuffer fo 0# start_pos# current# -- an error, really.
 522  else
 523     unsafeWriteBuffer (StringBuffer fo (current# -# start_pos#) start_pos# start_pos#)
 524                       (current# -# 1#)
 525                       '\NUL'#
 526
 527 \end{code}