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