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