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   writeHandle handle handle_
 269   if rc < (0::Int)
 270         then constructErrorAndFail "slurpFile"
 271         else return (chunk', rc+1 {-room for sentinel-})
 272
 273
 274 reAllocMem :: Addr -> Int -> IO Addr
 275 reAllocMem ptr sz = do
 276    chunk <- _ccall_ realloc ptr sz
 277    if chunk == nullAddr
 278 #if __GLASGOW_HASKELL__ < 303
 279       then fail (userError "reAllocMem")
 280 #else
 281       then fail "reAllocMem"
 282 #endif
 283       else return chunk
 284
 285 allocMem :: Int -> IO Addr
 286 allocMem sz = do
 287 #if __GLASGOW_HASKELL__ < 303
 288    chunk <- _ccall_ malloc sz
 289    if chunk == nullAddr
 290       then fail (userError "allocMem")
 291       else return chunk
 292 #else
 293    chunk <- _ccall_ allocMemory__ sz
 294    if chunk == nullAddr
 295       then constructErrorAndFail "allocMem"
 296       else return chunk
 297 #endif
 298 \end{code}
 299
 300 Lookup
 301
 302 \begin{code}
 303 currentChar  :: StringBuffer -> Char
 304 currentChar sb = case currentChar# sb of c -> C# c
 305
 306 lookAhead :: StringBuffer -> Int  -> Char
 307 lookAhead sb (I# i#) = case lookAhead# sb i# of c -> C# c
 308
 309 indexSBuffer :: StringBuffer -> Int -> Char
 310 indexSBuffer sb (I# i#) = case indexSBuffer# sb i# of c -> C# c
 311
 312 currentChar# :: StringBuffer -> Char#
 313 indexSBuffer# :: StringBuffer -> Int# -> Char#
 314 lookAhead# :: StringBuffer -> Int# -> Char#
 315 currentChar# (StringBuffer fo# _ _ current#) = indexCharOffAddr# fo# current#
 316 indexSBuffer# (StringBuffer fo# _ _ _) i# = indexCharOffAddr# fo# i#
 317
 318  -- relative lookup, i.e, currentChar = lookAhead 0
 319 lookAhead# (StringBuffer fo# _ _ c#) i# = indexCharOffAddr# fo# (c# +# i#)
 320
 321 currentIndex# :: StringBuffer -> Int#
 322 currentIndex# (StringBuffer fo# _ _ c#) = c#
 323
 324 lexemeIndex :: StringBuffer -> Int#
 325 lexemeIndex (StringBuffer fo# _ c# _) = c#
 326 \end{code}
 327
 328  moving the start point of the current lexeme.
 329
 330 \begin{code}
 331  -- moving the end point of the current lexeme.
 332 setCurrentPos# :: StringBuffer -> Int# -> StringBuffer
 333 setCurrentPos# (StringBuffer fo l# s# c#) i# =
 334  StringBuffer fo l# s# (c# +# i#)
 335
 336 -- augmenting the current lexeme by one.
 337 incLexeme :: StringBuffer -> StringBuffer
 338 incLexeme (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# +# 1#)
 339
 340 decLexeme :: StringBuffer -> StringBuffer
 341 decLexeme (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# -# 1#)
 342
 343 \end{code}
 344
 345 -- move the start and end point of the buffer on by
 346 -- x units.
 347
 348 \begin{code}
 349 stepOn :: StringBuffer -> StringBuffer
 350 stepOn (StringBuffer fo l# s# c#) = StringBuffer fo l# (s# +# 1#) (s# +# 1#) -- assume they're the same.
 351
 352 stepOnBy# :: StringBuffer -> Int# -> StringBuffer
 353 stepOnBy# (StringBuffer fo# l# s# c#) i# =
 354  case s# +# i# of
 355   new_s# -> StringBuffer fo# l# new_s# new_s#
 356
 357 -- jump to pos.
 358 stepOnTo# :: StringBuffer -> Int# -> StringBuffer
 359 stepOnTo# (StringBuffer fo l _ _) s# = StringBuffer fo l s# s#
 360
 361 squeezeLexeme :: StringBuffer -> Int# -> StringBuffer
 362 squeezeLexeme (StringBuffer fo l s# c#) i# = StringBuffer fo l (s# +# i#) c#
 363
 364 mergeLexemes :: StringBuffer -> StringBuffer -> StringBuffer
 365 mergeLexemes (StringBuffer fo l s# _) (StringBuffer _ _ _ c#)
 366    = StringBuffer fo l s# c#
 367
 368 stepOnUntil :: (Char -> Bool) -> StringBuffer -> StringBuffer
 369
 370 stepOnUntil pred (StringBuffer fo l# s# c#) =
 371  loop c#
 372   where
 373    loop c# =
 374     case indexCharOffAddr# fo c# of
 375      ch# | pred (C# ch#) -> StringBuffer fo l# c# c#
 376          | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# l# l# -- EOB, return immediately.
 377          | otherwise     -> loop (c# +# 1#)
 378
 379 stepOverLexeme :: StringBuffer -> StringBuffer
 380 stepOverLexeme (StringBuffer fo l s# c#) = StringBuffer fo l c# c#
 381
 382 expandWhile :: (Char -> Bool) -> StringBuffer -> StringBuffer
 383 expandWhile pred (StringBuffer fo l# s# c#) =
 384  loop c#
 385   where
 386    loop c# =
 387     case indexCharOffAddr# fo c# of
 388      ch# | pred (C# ch#) -> loop (c# +# 1#)
 389          | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# l# l# -- EOB, return immediately.
 390          | otherwise     -> StringBuffer fo l# s# c#
 391
 392 expandWhile# :: (Char# -> Bool) -> StringBuffer -> StringBuffer
 393 expandWhile# pred (StringBuffer fo l# s# c#) =
 394  loop c#
 395   where
 396    loop c# =
 397     case indexCharOffAddr# fo c# of
 398      ch# | pred ch# -> loop (c# +# 1#)
 399          | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# s# c# -- EOB, return immediately.
 400          | otherwise     -> StringBuffer fo l# s# c#
 401
 402 scanNumLit :: Integer -> StringBuffer -> (Integer,StringBuffer)
 403 scanNumLit acc (StringBuffer fo l# s# c#) =
 404  loop acc c#
 405   where
 406    loop acc c# =
 407     case indexCharOffAddr# fo c# of
 408      ch# | isDigit (C# ch#) -> loop (acc*10 + (toInteger (I# (ord# ch# -# ord# '0'#)))) (c# +# 1#)
 409          | ch# `eqChar#` '\NUL'# && c# >=# l# -> (acc, StringBuffer fo l# s# c#) -- EOB, return immediately.
 410          | otherwise        -> (acc,StringBuffer fo l# s# c#)
 411
 412
 413 expandUntilMatch :: StringBuffer -> String -> StringBuffer
 414 expandUntilMatch (StringBuffer fo l# s# c#) str =
 415   loop c# str
 416   where
 417    loop c# [] = StringBuffer fo l# s# c#
 418    loop c# ((C# x#):xs)
 419       | indexCharOffAddr# fo c# `eqChar#` x#
 420       = loop (c# +# 1#) xs
 421       | otherwise
 422       = loop (c# +# 1#) str
 423
 424 \end{code}
 425
 426 \begin{code}
 427    -- at or beyond end of buffer?
 428 bufferExhausted :: StringBuffer -> Bool
 429 bufferExhausted (StringBuffer fo l# _ c#) = c# >=# l#
 430
 431 emptyLexeme :: StringBuffer -> Bool
 432 emptyLexeme (StringBuffer fo l# s# c#) = s# ==# c#
 433
 434  -- matching
 435 prefixMatch :: StringBuffer -> String -> Maybe StringBuffer
 436 prefixMatch (StringBuffer fo l# s# c#) str =
 437   loop c# str
 438   where
 439    loop c# [] = Just (StringBuffer fo l# s# c#)
 440    loop c# ((C# x#):xs)
 441      | indexCharOffAddr# fo c# `eqChar#` x#
 442      = loop (c# +# 1#) xs
 443      | otherwise
 444      = Nothing
 445
 446 untilEndOfString# :: StringBuffer -> StringBuffer
 447 untilEndOfString# (StringBuffer fo l# s# c#) =
 448  loop c#
 449  where
 450   getch# i# = indexCharOffAddr# fo i#
 451
 452   loop c# =
 453    case getch# c# of
 454     '\"'# ->
 455       case getch# (c# -# 1#) of
 456         '\\'# ->
 457                   -- looks like an escaped something or other to me,
 458                   -- better count the number of "\\"s that are immediately
 459                   -- preceeding to decide if the " is escaped.
 460               let
 461                odd_slashes flg i# =
 462                 case getch# i# of
 463                  '\\'# -> odd_slashes (not flg) (i# -# 1#)
 464                  _     -> flg
 465               in
 466               if odd_slashes True (c# -# 2#) then
 467                   -- odd number, " is ecaped.
 468                   loop (c# +# 1#)
 469               else  -- a real end of string delimiter after all.
 470                   StringBuffer fo l# s# c#
 471         _ -> StringBuffer fo l# s# c#
 472     '\NUL'# ->
 473         if c# >=# l# then -- hit sentinel, this doesn't look too good..
 474            StringBuffer fo l# l# l#
 475         else
 476            loop (c# +# 1#)
 477     _ -> loop (c# +# 1#)
 478
 479
 480 untilChar# :: StringBuffer -> Char# -> StringBuffer
 481 untilChar# (StringBuffer fo l# s# c#) x# =
 482  loop c#
 483  where
 484   loop c#
 485    | c# >=# l# || indexCharOffAddr# fo c# `eqChar#` x#
 486    = StringBuffer fo l# s# c#
 487    | otherwise
 488    = loop (c# +# 1#)
 489
 490          -- conversion
 491 lexemeToString :: StringBuffer -> String
 492 lexemeToString (StringBuffer fo _ start_pos# current#) =
 493  if start_pos# ==# current# then
 494     ""
 495  else
 496     unpackCStringBA (copySubStr (A# fo) (I# start_pos#) (I# (current# -# start_pos#)))
 497
 498 lexemeToByteArray :: StringBuffer -> _ByteArray Int
 499 lexemeToByteArray (StringBuffer fo _ start_pos# current#) =
 500  if start_pos# ==# current# then
 501     error "lexemeToByteArray"
 502  else
 503     copySubStr (A# fo) (I# start_pos#) (I# (current# -# start_pos#))
 504
 505 lexemeToFastString :: StringBuffer -> FastString
 506 lexemeToFastString (StringBuffer fo l# start_pos# current#) =
 507  if start_pos# ==# current# then
 508     mkFastCharString2 (A# fo) (I# 0#)
 509  else
 510     mkFastSubString (A# fo) (I# start_pos#) (I# (current# -# start_pos#))
 511
 512 {-
 513  Create a StringBuffer from the current lexeme, and add a sentinel
 514  at the end. Know What You're Doing before taking this function
 515  into use..
 516 -}
 517 lexemeToBuffer :: StringBuffer -> StringBuffer
 518 lexemeToBuffer (StringBuffer fo l# start_pos# current#) =
 519  if start_pos# ==# current# then
 520     StringBuffer fo 0# start_pos# current# -- an error, really.
 521  else
 522     unsafeWriteBuffer (StringBuffer fo (current# -# start_pos#) start_pos# start_pos#)
 523                       (current# -# 1#)
 524                       '\NUL'#
 525
 526 \end{code}