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