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