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