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