ghc/compiler/parser/Lex.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[Lexical analysis]{Lexical analysis}
   5
   6 --------------------------------------------------------
   7 [Jan 98]
   8 There's a known bug in here:
   9
  10         If an interface file ends prematurely, Lex tries to
  11         do headFS of an empty FastString.
  12
  13 An example that provokes the error is
  14
  15         f _:_ _forall_ [a] <<<END OF FILE>>>
  16 --------------------------------------------------------
  17
  18 \begin{code}
  19 module Lex (
  20
  21         srcParseErr,
  22
  23         -- Monad for parser
  24         Token(..), lexer, ParseResult(..), PState(..),
  25         ExtFlags(..), mkPState,
  26         StringBuffer,
  27
  28         P, thenP, thenP_, returnP, mapP, failP, failMsgP,
  29         getSrcLocP, setSrcLocP, getSrcFile,
  30         layoutOn, layoutOff, pushContext, popContext
  31     ) where
  32
  33 #include "HsVersions.h"
  34
  35 import Char             ( toUpper )
  36
  37 import PrelNames        ( mkTupNameStr )
  38 import ForeignCall      ( Safety(..) )
  39 import UniqFM           ( listToUFM, lookupUFM )
  40 import BasicTypes       ( Boxity(..) )
  41 import SrcLoc           ( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
  42                           replaceSrcLine, mkSrcLoc )
  43
  44 import ErrUtils         ( Message )
  45 import Outputable
  46
  47 import FastString
  48 import StringBuffer
  49 import GlaExts
  50 import Ctype
  51 import Char             ( chr, ord )
  52
  53 import Bits             ( Bits(..) )       -- non-std
  54
  55 #if __GLASGOW_HASKELL__ >= 503
  56 import GHC.Read         ( readRational__ ) -- Glasgow non-std
  57 #else
  58 import PrelRead         ( readRational__ ) -- Glasgow non-std
  59 #endif
  60 import Int              ( Int32 )
  61 \end{code}
  62
  63 %************************************************************************
  64 %*                                                                      *
  65 \subsection{Data types}
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 The token data type, fairly un-interesting except from one
  70 constructor, @ITidinfo@, which is used to lazily lex id info (arity,
  71 strictness, unfolding etc).
  72
  73 The Idea/Observation here is that the renamer needs to scan through
  74 all of an interface file before it can continue. But only a fraction
  75 of the information contained in the file turns out to be useful, so
  76 delaying as much as possible of the scanning and parsing of an
  77 interface file Makes Sense (Heap profiles of the compiler
  78 show a reduction in heap usage by at least a factor of two,
  79 post-renamer).
  80
  81 Hence, the interface file lexer spots when value declarations are
  82 being scanned and return the @ITidinfo@ and @ITtype@ constructors
  83 for the type and any other id info for that binding (unfolding, strictness
  84 etc). These constructors are applied to the result of lexing these sub-chunks.
  85
  86 The lexing of the type and id info is all done lazily, of course, so
  87 the scanning (and subsequent parsing) will be done *only* on the ids the
  88 renamer finds out that it is interested in. The rest will just be junked.
  89 Laziness, you know it makes sense :-)
  90
  91 \begin{code}
  92 data Token
  93   = ITas                        -- Haskell keywords
  94   | ITcase
  95   | ITclass
  96   | ITdata
  97   | ITdefault
  98   | ITderiving
  99   | ITdo
 100   | ITelse
 101   | IThiding
 102   | ITif
 103   | ITimport
 104   | ITin
 105   | ITinfix
 106   | ITinfixl
 107   | ITinfixr
 108   | ITinstance
 109   | ITlet
 110   | ITmodule
 111   | ITnewtype
 112   | ITof
 113   | ITqualified
 114   | ITthen
 115   | ITtype
 116   | ITwhere
 117   | ITscc                       -- ToDo: remove (we use {-# SCC "..." #-} now)
 118
 119   | ITforall                    -- GHC extension keywords
 120   | ITforeign
 121   | ITexport
 122   | ITlabel
 123   | ITdynamic
 124   | ITsafe
 125   | ITthreadsafe
 126   | ITunsafe
 127   | ITwith
 128   | ITstdcallconv
 129   | ITccallconv
 130   | ITdotnet
 131   | ITccall (Bool,Bool,Safety)  -- (is_dyn, is_casm, may_gc)
 132
 133   | ITspecialise_prag           -- Pragmas
 134   | ITsource_prag
 135   | ITinline_prag
 136   | ITnoinline_prag
 137   | ITrules_prag
 138   | ITdeprecated_prag
 139   | ITline_prag
 140   | ITscc_prag
 141   | ITclose_prag
 142
 143   | ITdotdot                    -- reserved symbols
 144   | ITdcolon
 145   | ITequal
 146   | ITlam
 147   | ITvbar
 148   | ITlarrow
 149   | ITrarrow
 150   | ITat
 151   | ITtilde
 152   | ITdarrow
 153   | ITminus
 154   | ITbang
 155   | ITstar
 156   | ITdot
 157
 158   | ITbiglam                    -- GHC-extension symbols
 159
 160   | ITocurly                    -- special symbols
 161   | ITccurly
 162   | ITocurlybar                 -- {|, for type applications
 163   | ITccurlybar                 -- |}, for type applications
 164   | ITvccurly
 165   | ITobrack
 166   | ITopabrack                  -- [:, for parallel arrays with -fparr
 167   | ITcpabrack                  -- :], for parallel arrays with -fparr
 168   | ITcbrack
 169   | IToparen
 170   | ITcparen
 171   | IToubxparen
 172   | ITcubxparen
 173   | ITsemi
 174   | ITcomma
 175   | ITunderscore
 176   | ITbackquote
 177
 178   | ITvarid   FAST_STRING       -- identifiers
 179   | ITconid   FAST_STRING
 180   | ITvarsym  FAST_STRING
 181   | ITconsym  FAST_STRING
 182   | ITqvarid  (FAST_STRING,FAST_STRING)
 183   | ITqconid  (FAST_STRING,FAST_STRING)
 184   | ITqvarsym (FAST_STRING,FAST_STRING)
 185   | ITqconsym (FAST_STRING,FAST_STRING)
 186
 187   | ITdupipvarid   FAST_STRING  -- GHC extension: implicit param: ?x
 188   | ITsplitipvarid FAST_STRING  -- GHC extension: implicit param: %x
 189
 190   | ITpragma StringBuffer
 191
 192   | ITchar       Int
 193   | ITstring     FAST_STRING
 194   | ITinteger    Integer
 195   | ITrational   Rational
 196
 197   | ITprimchar   Int
 198   | ITprimstring FAST_STRING
 199   | ITprimint    Integer
 200   | ITprimfloat  Rational
 201   | ITprimdouble Rational
 202   | ITlitlit     FAST_STRING
 203
 204   | ITunknown String            -- Used when the lexer can't make sense of it
 205   | ITeof                       -- end of file token
 206   deriving Show -- debugging
 207 \end{code}
 208
 209 -----------------------------------------------------------------------------
 210 Keyword Lists
 211
 212 \begin{code}
 213 pragmaKeywordsFM = listToUFM $
 214       map (\ (x,y) -> (_PK_ x,y))
 215        [( "SPECIALISE", ITspecialise_prag ),
 216         ( "SPECIALIZE", ITspecialise_prag ),
 217         ( "SOURCE",     ITsource_prag ),
 218         ( "INLINE",     ITinline_prag ),
 219         ( "NOINLINE",   ITnoinline_prag ),
 220         ( "NOTINLINE",  ITnoinline_prag ),
 221         ( "LINE",       ITline_prag ),
 222         ( "RULES",      ITrules_prag ),
 223         ( "RULEZ",      ITrules_prag ), -- american spelling :-)
 224         ( "SCC",        ITscc_prag ),
 225         ( "DEPRECATED", ITdeprecated_prag )
 226         ]
 227
 228 haskellKeywordsFM = listToUFM $
 229       map (\ (x,y) -> (_PK_ x,y))
 230        [( "_",          ITunderscore ),
 231         ( "as",         ITas ),
 232         ( "case",       ITcase ),
 233         ( "class",      ITclass ),
 234         ( "data",       ITdata ),
 235         ( "default",    ITdefault ),
 236         ( "deriving",   ITderiving ),
 237         ( "do",         ITdo ),
 238         ( "else",       ITelse ),
 239         ( "hiding",     IThiding ),
 240         ( "if",         ITif ),
 241         ( "import",     ITimport ),
 242         ( "in",         ITin ),
 243         ( "infix",      ITinfix ),
 244         ( "infixl",     ITinfixl ),
 245         ( "infixr",     ITinfixr ),
 246         ( "instance",   ITinstance ),
 247         ( "let",        ITlet ),
 248         ( "module",     ITmodule ),
 249         ( "newtype",    ITnewtype ),
 250         ( "of",         ITof ),
 251         ( "qualified",  ITqualified ),
 252         ( "then",       ITthen ),
 253         ( "type",       ITtype ),
 254         ( "where",      ITwhere ),
 255         ( "_scc_",      ITscc )         -- ToDo: remove
 256      ]
 257
 258 isSpecial :: Token -> Bool
 259 -- If we see M.x, where x is a keyword, but
 260 -- is special, we treat is as just plain M.x,
 261 -- not as a keyword.
 262 isSpecial ITas          = True
 263 isSpecial IThiding      = True
 264 isSpecial ITqualified   = True
 265 isSpecial ITforall      = True
 266 isSpecial ITexport      = True
 267 isSpecial ITlabel       = True
 268 isSpecial ITdynamic     = True
 269 isSpecial ITsafe        = True
 270 isSpecial ITthreadsafe  = True
 271 isSpecial ITunsafe      = True
 272 isSpecial ITwith        = True
 273 isSpecial ITccallconv   = True
 274 isSpecial ITstdcallconv = True
 275 isSpecial _             = False
 276
 277 -- IMPORTANT: Keep this in synch with ParseIface.y's var_fs production! (SUP)
 278 ghcExtensionKeywordsFM = listToUFM $
 279         map (\ (x,y) -> (_PK_ x,y))
 280      [  ( "forall",     ITforall ),
 281         ( "foreign",    ITforeign ),
 282         ( "export",     ITexport ),
 283         ( "label",      ITlabel ),
 284         ( "dynamic",    ITdynamic ),
 285         ( "safe",       ITsafe ),
 286         ( "threadsafe", ITthreadsafe ),
 287         ( "unsafe",     ITunsafe ),
 288         ( "with",       ITwith ),
 289         ( "stdcall",    ITstdcallconv),
 290         ( "ccall",      ITccallconv),
 291         ( "dotnet",     ITdotnet),
 292         ("_ccall_",     ITccall (False, False, PlayRisky)),
 293         ("_ccall_GC_",  ITccall (False, False, PlaySafe False)),
 294         ("_casm_",      ITccall (False, True,  PlayRisky)),
 295         ("_casm_GC_",   ITccall (False, True,  PlaySafe False))
 296      ]
 297
 298
 299 haskellKeySymsFM = listToUFM $
 300         map (\ (x,y) -> (_PK_ x,y))
 301       [ ("..",          ITdotdot)
 302        ,("::",          ITdcolon)
 303        ,("=",           ITequal)
 304        ,("\\",          ITlam)
 305        ,("|",           ITvbar)
 306        ,("<-",          ITlarrow)
 307        ,("->",          ITrarrow)
 308        ,("@",           ITat)
 309        ,("~",           ITtilde)
 310        ,("=>",          ITdarrow)
 311        ,("-",           ITminus)
 312        ,("!",           ITbang)
 313        ,("*",           ITstar)
 314        ,(".",           ITdot)          -- sadly, for 'forall a . t'
 315        ]
 316 \end{code}
 317
 318 -----------------------------------------------------------------------------
 319 The lexical analyser
 320
 321 Lexer state:
 322
 323         - (exts)  lexing a source with extensions, eg, an interface file or
 324                   with -fglasgow-exts
 325         - (bol)   pointer to beginning of line (for column calculations)
 326         - (buf)   pointer to beginning of token
 327         - (buf)   pointer to current char
 328         - (atbol) flag indicating whether we're at the beginning of a line
 329
 330 \begin{code}
 331 lexer :: (Token -> P a) -> P a
 332 lexer cont buf s@(PState{
 333                     loc = loc,
 334                     extsBitmap = exts,
 335                     bol = bol,
 336                     atbol = atbol,
 337                     context = ctx
 338                 })
 339
 340         -- first, start a new lexeme and lose all the whitespace
 341   =  _scc_ "Lexer"
 342   tab line bol atbol (stepOverLexeme buf)
 343   where
 344         line = srcLocLine loc
 345
 346         tab y bol atbol buf = --trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $
 347           case currentChar# buf of
 348
 349             '\NUL'# ->
 350                    if bufferExhausted (stepOn buf)
 351                         then cont ITeof buf s'
 352                         else trace "lexer: misplaced NUL?" $
 353                              tab y bol atbol (stepOn buf)
 354
 355             '\n'# -> let buf' = stepOn buf
 356                      in tab (y +# 1#) (currentIndex# buf') 1# buf'
 357
 358                 -- find comments.  This got harder in Haskell 98.
 359             '-'# ->  let trundle n =
 360                           let next = lookAhead# buf n in
 361                           if next `eqChar#` '-'# then trundle (n +# 1#)
 362                           else if is_symbol next || n <# 2#
 363                                 then is_a_token
 364                                 else tab y bol atbol
 365                                          (stepOnUntilChar# (stepOnBy# buf n) '\n'#)
 366                     in trundle 1#
 367
 368                 -- comments and pragmas.  We deal with LINE pragmas here,
 369                 -- and throw out any unrecognised pragmas as comments.  Any
 370                 -- pragmas we know about are dealt with later (after any layout
 371                 -- processing if necessary).
 372             '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
 373                 if lookAhead# buf 2# `eqChar#` '#'# then
 374                   case expandWhile# is_space (setCurrentPos# buf 3#) of { buf1->
 375                   case expandWhile# is_ident (stepOverLexeme buf1)   of { buf2->
 376                   let lexeme = mkFastString -- ToDo: too slow
 377                                   (map toUpper (lexemeToString buf2)) in
 378                   case lookupUFM pragmaKeywordsFM lexeme of
 379                         -- ignore RULES pragmas when -fglasgow-exts is off
 380                         Just ITrules_prag | not (glaExtsEnabled exts) ->
 381                            skip_to_end (stepOnBy# buf 2#) s'
 382                         Just ITline_prag ->
 383                            line_prag skip_to_end buf2 s'
 384                         Just other -> is_a_token
 385                         Nothing -> skip_to_end (stepOnBy# buf 2#) s'
 386                   }}
 387
 388                 else skip_to_end (stepOnBy# buf 2#) s'
 389                 where
 390                     skip_to_end = skipNestedComment (lexer cont)
 391
 392                 -- special GHC extension: we grok cpp-style #line pragmas
 393             '#'# | lexemeIndex buf ==# bol ->   -- the '#' must be in column 0
 394                 let buf1 | lookAhead# buf 1# `eqChar#` 'l'# &&
 395                            lookAhead# buf 2# `eqChar#` 'i'# &&
 396                            lookAhead# buf 3# `eqChar#` 'n'# &&
 397                            lookAhead# buf 4# `eqChar#` 'e'#  = stepOnBy# buf 5#
 398                          | otherwise = stepOn buf
 399                 in
 400                 case expandWhile# is_space buf1 of { buf2 ->
 401                 if is_digit (currentChar# buf2)
 402                         then line_prag next_line buf2 s'
 403                         else is_a_token
 404                 }
 405                 where
 406                 next_line buf = lexer cont (stepOnUntilChar# buf '\n'#)
 407
 408                 -- tabs have been expanded beforehand
 409             c | is_space c -> tab y bol atbol (stepOn buf)
 410               | otherwise  -> is_a_token
 411
 412            where s' = s{loc = replaceSrcLine loc y,
 413                         bol = bol,
 414                        atbol = atbol}
 415
 416                  is_a_token | atbol /=# 0# = lexBOL cont buf s'
 417                             | otherwise    = lexToken cont exts buf s'
 418
 419 -- {-# LINE .. #-} pragmas.  yeuch.
 420 line_prag cont buf s@PState{loc=loc} =
 421   case expandWhile# is_space buf                of { buf1 ->
 422   case scanNumLit 0 (stepOverLexeme buf1)       of { (line,buf2) ->
 423   -- subtract one: the line number refers to the *following* line.
 424   let real_line = line - 1 in
 425   case fromInteger real_line                    of { i@(I# l) ->
 426         -- ToDo, if no filename then we skip the newline.... d'oh
 427   case expandWhile# is_space buf2               of { buf3 ->
 428   case currentChar# buf3                        of
 429      '\"'#{-"-} ->
 430         case untilEndOfString# (stepOn (stepOverLexeme buf3)) of { buf4 ->
 431         let
 432             file = lexemeToFastString buf4
 433             new_buf = stepOn (stepOverLexeme buf4)
 434         in
 435         if nullFastString file
 436                 then cont new_buf s{loc = replaceSrcLine loc l}
 437                 else cont new_buf s{loc = mkSrcLoc file i}
 438         }
 439      _other -> cont (stepOverLexeme buf3) s{loc = replaceSrcLine loc l}
 440   }}}}
 441
 442 skipNestedComment :: P a -> P a
 443 skipNestedComment cont buf state = skipNestedComment' (loc state) cont buf state
 444
 445 skipNestedComment' :: SrcLoc -> P a -> P a
 446 skipNestedComment' orig_loc cont buf = loop buf
 447  where
 448    loop buf =
 449      case currentChar# buf of
 450         '-'# | lookAhead# buf 1# `eqChar#` '}'# -> cont (stepOnBy# buf 2#)
 451
 452         '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
 453               skipNestedComment
 454                 (skipNestedComment' orig_loc cont)
 455                 (stepOnBy# buf 2#)
 456
 457         '\n'# -> \ s@PState{loc=loc} ->
 458                  let buf' = stepOn buf in
 459                  loop buf' s{loc = incSrcLine loc,
 460                              bol = currentIndex# buf',
 461                              atbol = 1#}
 462
 463         -- pass the original SrcLoc to lexError so that the error is
 464         -- reported at the line it was originally on, not the line at
 465         -- the end of the file.
 466         '\NUL'# | bufferExhausted (stepOn buf) ->
 467                 \s -> lexError "unterminated `{-'" buf s{loc=orig_loc} -- -}
 468
 469         _   -> loop (stepOn buf)
 470
 471 -- When we are lexing the first token of a line, check whether we need to
 472 -- insert virtual semicolons or close braces due to layout.
 473
 474 lexBOL :: (Token -> P a) -> P a
 475 lexBOL cont buf s@(PState{
 476                     loc = loc,
 477                     extsBitmap = exts,
 478                     bol = bol,
 479                     atbol = atbol,
 480                     context = ctx
 481                   }) =
 482         if need_close_curly then
 483                 --trace ("col = " ++ show (I# col) ++ ", layout: inserting '}'") $
 484                 cont ITvccurly buf s{atbol = 1#, context = tail ctx}
 485         else if need_semi_colon then
 486                 --trace ("col = " ++ show (I# col) ++ ", layout: inserting ';'") $
 487                 cont ITsemi buf s{atbol = 0#}
 488         else
 489                 lexToken cont exts buf s{atbol = 0#}
 490   where
 491         col = currentIndex# buf -# bol
 492
 493         need_close_curly =
 494                 case ctx of
 495                         [] -> False
 496                         (i:_) -> case i of
 497                                     NoLayout -> False
 498                                     Layout n -> col <# n
 499         need_semi_colon =
 500                 case ctx of
 501                         [] -> False
 502                         (i:_) -> case i of
 503                                     NoLayout -> False
 504                                     Layout n -> col ==# n
 505
 506
 507 lexToken :: (Token -> P a) -> Int# -> P a
 508 lexToken cont exts buf =
 509 -- trace "lexToken" $
 510   case currentChar# buf of
 511
 512     -- special symbols ----------------------------------------------------
 513     '('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'#
 514                 -> cont IToubxparen (setCurrentPos# buf 2#)
 515          | otherwise
 516                 -> cont IToparen (incLexeme buf)
 517
 518     ')'# -> cont ITcparen    (incLexeme buf)
 519     '['# | parrEnabled exts && lookAhead# buf 1# `eqChar#` ':'# ->
 520             cont ITopabrack  (setCurrentPos# buf 2#)
 521          | otherwise ->
 522             cont ITobrack    (incLexeme buf)
 523     ']'# -> cont ITcbrack    (incLexeme buf)
 524     ','# -> cont ITcomma     (incLexeme buf)
 525     ';'# -> cont ITsemi      (incLexeme buf)
 526     '}'# -> \ s@PState{context = ctx} ->
 527             case ctx of
 528                 (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'}
 529                 _        -> lexError "too many '}'s" buf s
 530     '|'# -> case lookAhead# buf 1# of
 531                  '}'#  | glaExtsEnabled exts -> cont ITccurlybar
 532                                                      (setCurrentPos# buf 2#)
 533                  _                           -> lex_sym cont (incLexeme buf)
 534     ':'# -> case lookAhead# buf 1# of
 535                  ']'#  | parrEnabled exts    -> cont ITcpabrack
 536                                                      (setCurrentPos# buf 2#)
 537                  _                           -> lex_sym cont (incLexeme buf)
 538
 539
 540     '#'# -> case lookAhead# buf 1# of
 541                 ')'#  | glaExtsEnabled exts
 542                      -> cont ITcubxparen (setCurrentPos# buf 2#)
 543                 '-'# -> case lookAhead# buf 2# of
 544                            '}'# -> cont ITclose_prag (setCurrentPos# buf 3#)
 545                            _    -> lex_sym cont (incLexeme buf)
 546                 _    -> lex_sym cont (incLexeme buf)
 547
 548     '`'# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '`'#
 549                 -> lex_cstring cont (setCurrentPos# buf 2#)
 550          | otherwise
 551                 -> cont ITbackquote (incLexeme buf)
 552
 553     '{'# ->   -- for Emacs: -}
 554             case lookAhead# buf 1# of
 555            '|'# | glaExtsEnabled exts
 556                 -> cont ITocurlybar (setCurrentPos# buf 2#)
 557            '-'# -> case lookAhead# buf 2# of
 558                     '#'# -> lex_prag cont (setCurrentPos# buf 3#)
 559                     _    -> cont ITocurly (incLexeme buf)
 560            _ -> (layoutOff `thenP_` cont ITocurly)  (incLexeme buf)
 561
 562     -- strings/characters -------------------------------------------------
 563     '\"'#{-"-} -> lex_string cont exts [] (incLexeme buf)
 564     '\''#      -> lex_char (char_end cont) exts (incLexeme buf)
 565
 566         -- Hexadecimal and octal constants
 567     '0'# | (ch `eqChar#` 'x'# || ch `eqChar#` 'X'#) && is_hexdigit ch2
 568                 -> readNum (after_lexnum cont exts) buf' is_hexdigit 16 hex
 569          | (ch `eqChar#` 'o'# || ch `eqChar#` 'O'#) && is_octdigit ch2
 570                 -> readNum (after_lexnum cont exts) buf' is_octdigit  8 oct_or_dec
 571         where ch   = lookAhead# buf 1#
 572               ch2  = lookAhead# buf 2#
 573               buf' = setCurrentPos# buf 2#
 574
 575     '\NUL'# ->
 576             if bufferExhausted (stepOn buf) then
 577                cont ITeof buf
 578             else
 579                trace "lexIface: misplaced NUL?" $
 580                cont (ITunknown "\NUL") (stepOn buf)
 581
 582     '?'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) ->
 583             lex_ip ITdupipvarid cont (incLexeme buf)
 584     '%'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) ->
 585             lex_ip ITsplitipvarid cont (incLexeme buf)
 586     c | is_digit  c -> lex_num cont exts 0 buf
 587       | is_symbol c -> lex_sym cont buf
 588       | is_upper  c -> lex_con cont exts buf
 589       | is_ident  c -> lex_id  cont exts buf
 590       | otherwise   -> lexError "illegal character" buf
 591
 592 -- Int# is unlifted, and therefore faster than Bool for flags.
 593 {-# INLINE flag #-}
 594 flag :: Int# -> Bool
 595 flag 0# = False
 596 flag _  = True
 597
 598 -------------------------------------------------------------------------------
 599 -- Pragmas
 600
 601 lex_prag cont buf
 602   = case expandWhile# is_space buf of { buf1 ->
 603     case expandWhile# is_ident (stepOverLexeme buf1) of { buf2 ->
 604     let lexeme = mkFastString (map toUpper (lexemeToString buf2)) in
 605     case lookupUFM pragmaKeywordsFM lexeme of
 606         Just kw -> cont kw (mergeLexemes buf buf2)
 607         Nothing -> panic "lex_prag"
 608   }}
 609
 610 -------------------------------------------------------------------------------
 611 -- Strings & Chars
 612
 613 lex_string cont exts s buf
 614   = case currentChar# buf of
 615         '"'#{-"-} ->
 616            let buf' = incLexeme buf
 617                s' = mkFastStringNarrow (map chr (reverse s))
 618            in case currentChar# buf' of
 619                 '#'# | glaExtsEnabled exts -> if all (<= 0xFF) s
 620                     then cont (ITprimstring s') (incLexeme buf')
 621                     else lexError "primitive string literal must contain only characters <= \'\\xFF\'" buf'
 622                 _                   -> cont (ITstring s') buf'
 623
 624         -- ignore \& in a string, deal with string gaps
 625         '\\'# | next_ch `eqChar#` '&'#
 626                 -> lex_string cont exts s buf'
 627               | is_space next_ch
 628                 -> lex_stringgap cont exts s (incLexeme buf)
 629
 630             where next_ch = lookAhead# buf 1#
 631                   buf' = setCurrentPos# buf 2#
 632
 633         _ -> lex_char (lex_next_string cont s) exts buf
 634
 635 lex_stringgap cont exts s buf
 636   = let buf' = incLexeme buf in
 637     case currentChar# buf of
 638         '\n'# -> \st@PState{loc = loc} -> lex_stringgap cont exts s buf'
 639                   st{loc = incSrcLine loc}
 640         '\\'# -> lex_string cont exts s buf'
 641         c | is_space c -> lex_stringgap cont exts s buf'
 642         other -> charError buf'
 643
 644 lex_next_string cont s exts c buf = lex_string cont exts (c:s) buf
 645
 646 lex_char :: (Int# -> Int -> P a) -> Int# -> P a
 647 lex_char cont exts buf
 648   = case currentChar# buf of
 649         '\\'# -> lex_escape (cont exts) (incLexeme buf)
 650         c | is_any c -> cont exts (I# (ord# c)) (incLexeme buf)
 651         other -> charError buf
 652
 653 char_end cont exts c buf
 654   = case currentChar# buf of
 655         '\''# -> let buf' = incLexeme buf in
 656                  case currentChar# buf' of
 657                         '#'# | glaExtsEnabled exts
 658                                 -> cont (ITprimchar c) (incLexeme buf')
 659                         _       -> cont (ITchar c) buf'
 660         _     -> charError buf
 661
 662 lex_escape cont buf
 663   = let buf' = incLexeme buf in
 664     case currentChar# buf of
 665         'a'#       -> cont (ord '\a') buf'
 666         'b'#       -> cont (ord '\b') buf'
 667         'f'#       -> cont (ord '\f') buf'
 668         'n'#       -> cont (ord '\n') buf'
 669         'r'#       -> cont (ord '\r') buf'
 670         't'#       -> cont (ord '\t') buf'
 671         'v'#       -> cont (ord '\v') buf'
 672         '\\'#      -> cont (ord '\\') buf'
 673         '"'#       -> cont (ord '\"') buf'
 674         '\''#      -> cont (ord '\'') buf'
 675         '^'#       -> let c = currentChar# buf' in
 676                       if c `geChar#` '@'# && c `leChar#` '_'#
 677                         then cont (I# (ord# c -# ord# '@'#)) (incLexeme buf')
 678                         else charError buf'
 679
 680         'x'#      -> readNum (after_charnum cont) buf' is_hexdigit 16 hex
 681         'o'#      -> readNum (after_charnum cont) buf' is_octdigit  8 oct_or_dec
 682         x | is_digit x
 683                   -> readNum (after_charnum cont) buf is_digit    10 oct_or_dec
 684
 685         _          -> case [ (c,buf2) | (p,c) <- silly_escape_chars,
 686                                        Just buf2 <- [prefixMatch buf p] ] of
 687                             (c,buf2):_ -> cont (ord c) buf2
 688                             [] -> charError buf'
 689
 690 after_charnum cont i buf
 691   = if i >= 0 && i <= 0x10FFFF
 692         then cont (fromInteger i) buf
 693         else charError buf
 694
 695 readNum cont buf is_digit base conv = read buf 0
 696   where read buf i
 697           = case currentChar# buf of { c ->
 698             if is_digit c
 699                 then read (incLexeme buf) (i*base + (toInteger (I# (conv c))))
 700                 else cont i buf
 701             }
 702
 703 is_hexdigit c
 704         =  is_digit c
 705         || (c `geChar#` 'a'# && c `leChar#` 'f'#)
 706         || (c `geChar#` 'A'# && c `leChar#` 'F'#)
 707
 708 hex c | is_digit c = ord# c -# ord# '0'#
 709       | otherwise  = ord# (to_lower c) -# ord# 'a'# +# 10#
 710 oct_or_dec c = ord# c -# ord# '0'#
 711
 712 is_octdigit c = c `geChar#` '0'# && c `leChar#` '7'#
 713
 714 to_lower c
 715   | c `geChar#` 'A'# && c `leChar#` 'Z'#
 716         = chr# (ord# c -# (ord# 'A'# -# ord# 'a'#))
 717   | otherwise = c
 718
 719 charError buf = lexError "error in character literal" buf
 720
 721 silly_escape_chars = [
 722         ("NUL", '\NUL'),
 723         ("SOH", '\SOH'),
 724         ("STX", '\STX'),
 725         ("ETX", '\ETX'),
 726         ("EOT", '\EOT'),
 727         ("ENQ", '\ENQ'),
 728         ("ACK", '\ACK'),
 729         ("BEL", '\BEL'),
 730         ("BS", '\BS'),
 731         ("HT", '\HT'),
 732         ("LF", '\LF'),
 733         ("VT", '\VT'),
 734         ("FF", '\FF'),
 735         ("CR", '\CR'),
 736         ("SO", '\SO'),
 737         ("SI", '\SI'),
 738         ("DLE", '\DLE'),
 739         ("DC1", '\DC1'),
 740         ("DC2", '\DC2'),
 741         ("DC3", '\DC3'),
 742         ("DC4", '\DC4'),
 743         ("NAK", '\NAK'),
 744         ("SYN", '\SYN'),
 745         ("ETB", '\ETB'),
 746         ("CAN", '\CAN'),
 747         ("EM", '\EM'),
 748         ("SUB", '\SUB'),
 749         ("ESC", '\ESC'),
 750         ("FS", '\FS'),
 751         ("GS", '\GS'),
 752         ("RS", '\RS'),
 753         ("US", '\US'),
 754         ("SP", '\SP'),
 755         ("DEL", '\DEL')
 756         ]
 757
 758 -----------------------------------------------------------------------------
 759 -- Numbers
 760
 761 lex_num :: (Token -> P a) -> Int# -> Integer -> P a
 762 lex_num cont exts acc buf =
 763  case scanNumLit acc buf of
 764      (acc',buf') ->
 765        case currentChar# buf' of
 766          '.'# | is_digit (lookAhead# buf' 1#) ->
 767              -- this case is not optimised at all, as the
 768              -- presence of floating point numbers in interface
 769              -- files is not that common. (ToDo)
 770             case expandWhile# is_digit (incLexeme buf') of
 771               buf2 -> -- points to first non digit char
 772
 773                 let l = case currentChar# buf2 of
 774                           'E'# -> do_exponent
 775                           'e'# -> do_exponent
 776                           _ -> buf2
 777
 778                     do_exponent
 779                         = let buf3 = incLexeme buf2 in
 780                           case currentChar# buf3 of
 781                                 '-'# | is_digit (lookAhead# buf3 1#)
 782                                    -> expandWhile# is_digit (incLexeme buf3)
 783                                 '+'# | is_digit (lookAhead# buf3 1#)
 784                                    -> expandWhile# is_digit (incLexeme buf3)
 785                                 x | is_digit x -> expandWhile# is_digit buf3
 786                                 _ -> buf2
 787
 788                     v = readRational__ (lexemeToString l)
 789
 790                 in case currentChar# l of -- glasgow exts only
 791                       '#'# | glaExtsEnabled exts -> let l' = incLexeme l in
 792                               case currentChar# l' of
 793                                 '#'# -> cont (ITprimdouble v) (incLexeme l')
 794                                 _    -> cont (ITprimfloat  v) l'
 795                       _ -> cont (ITrational v) l
 796
 797          _ -> after_lexnum cont exts acc' buf'
 798
 799 after_lexnum cont exts i buf
 800   = case currentChar# buf of
 801         '#'# | glaExtsEnabled exts -> cont (ITprimint i) (incLexeme buf)
 802         _                          -> cont (ITinteger i) buf
 803
 804 -----------------------------------------------------------------------------
 805 -- C "literal literal"s  (i.e. things like ``NULL'', ``stdout'' etc.)
 806
 807 -- we lexemeToFastString on the bit between the ``''s, but include the
 808 -- quotes in the full lexeme.
 809
 810 lex_cstring cont buf =
 811  case expandUntilMatch (stepOverLexeme buf) "\'\'" of
 812    Just buf' -> cont (ITlitlit (lexemeToFastString
 813                                 (setCurrentPos# buf' (negateInt# 2#))))
 814                    (mergeLexemes buf buf')
 815    Nothing   -> lexError "unterminated ``" buf
 816
 817 -----------------------------------------------------------------------------
 818 -- identifiers, symbols etc.
 819
 820 lex_ip ip_constr cont buf =
 821  case expandWhile# is_ident buf of
 822    buf' -> cont (ip_constr (tailFS lexeme)) buf'
 823         where lexeme = lexemeToFastString buf'
 824
 825 lex_id cont exts buf =
 826  let buf1 = expandWhile# is_ident buf in
 827  seq buf1 $
 828
 829  case (if glaExtsEnabled exts
 830         then expandWhile# (eqChar# '#'#) buf1 -- slurp trailing hashes
 831         else buf1)                              of { buf' ->
 832  seq buf' $
 833
 834  let lexeme  = lexemeToFastString buf' in
 835
 836  case _scc_ "haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
 837         Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $
 838                           cont kwd_token buf';
 839         Nothing        ->
 840
 841  let var_token = cont (ITvarid lexeme) buf' in
 842
 843  if not (glaExtsEnabled exts)
 844    then var_token
 845    else
 846
 847  case lookupUFM ghcExtensionKeywordsFM lexeme of {
 848         Just kwd_token -> cont kwd_token buf';
 849         Nothing        -> var_token
 850
 851  }}}
 852
 853 lex_sym cont buf =
 854  -- trace "lex_sym" $
 855  case expandWhile# is_symbol buf of
 856    buf' -> case lookupUFM haskellKeySymsFM lexeme of {
 857                 Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
 858                                   cont kwd_token buf' ;
 859                 Nothing        -> --trace ("sym: "++unpackFS lexeme) $
 860                                   cont (mk_var_token lexeme) buf'
 861            }
 862         where lexeme = lexemeToFastString buf'
 863
 864
 865 -- lex_con recursively collects components of a qualified identifer.
 866 -- The argument buf is the StringBuffer representing the lexeme
 867 -- identified so far, where the next character is upper-case.
 868
 869 lex_con cont exts buf =
 870  -- trace ("con: "{-++unpackFS lexeme-}) $
 871  let empty_buf = stepOverLexeme buf in
 872  case expandWhile# is_ident empty_buf of { buf1 ->
 873  case slurp_trailing_hashes buf1 exts of { con_buf ->
 874
 875  let all_buf = mergeLexemes buf con_buf
 876
 877      con_lexeme = lexemeToFastString con_buf
 878      mod_lexeme = lexemeToFastString (decLexeme buf)
 879      all_lexeme = lexemeToFastString all_buf
 880
 881      just_a_conid
 882         | emptyLexeme buf = cont (ITconid con_lexeme)               all_buf
 883         | otherwise       = cont (ITqconid (mod_lexeme,con_lexeme)) all_buf
 884  in
 885
 886  case currentChar# all_buf of
 887      '.'# -> maybe_qualified cont exts all_lexeme
 888                 (incLexeme all_buf) just_a_conid
 889      _    -> just_a_conid
 890   }}
 891
 892
 893 maybe_qualified cont exts mod buf just_a_conid =
 894  -- trace ("qid: "{-++unpackFS lexeme-}) $
 895  case currentChar# buf of
 896   '['# ->       -- Special case for []
 897     case lookAhead# buf 1# of
 898      ']'# -> cont (ITqconid  (mod,SLIT("[]"))) (setCurrentPos# buf 2#)
 899      _    -> just_a_conid
 900
 901   '('# ->  -- Special case for (,,,)
 902            -- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)"
 903     case lookAhead# buf 1# of
 904      '#'# | glaExtsEnabled exts -> case lookAhead# buf 2# of
 905                 ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#)
 906                                 just_a_conid
 907                 _    -> just_a_conid
 908      ')'# -> cont (ITqconid (mod,SLIT("()"))) (setCurrentPos# buf 2#)
 909      ','# -> lex_tuple cont mod (setCurrentPos# buf 2#) just_a_conid
 910      _    -> just_a_conid
 911
 912   '-'# -> case lookAhead# buf 1# of
 913             '>'# -> cont (ITqconid (mod,SLIT("(->)"))) (setCurrentPos# buf 2#)
 914             _    -> lex_id3 cont exts mod buf just_a_conid
 915
 916   _    -> lex_id3 cont exts mod buf just_a_conid
 917
 918
 919 lex_id3 cont exts mod buf just_a_conid
 920   | is_upper (currentChar# buf) =
 921      lex_con cont exts buf
 922
 923   | is_symbol (currentChar# buf) =
 924      let
 925         start_new_lexeme = stepOverLexeme buf
 926      in
 927      -- trace ("lex_id31 "{-++unpackFS lexeme-}) $
 928      case expandWhile# is_symbol start_new_lexeme of { buf' ->
 929      let
 930        lexeme  = lexemeToFastString buf'
 931         -- real lexeme is M.<sym>
 932        new_buf = mergeLexemes buf buf'
 933      in
 934      cont (mk_qvar_token mod lexeme) new_buf
 935         -- wrong, but arguably morally right: M... is now a qvarsym
 936      }
 937
 938   | otherwise   =
 939      let
 940         start_new_lexeme = stepOverLexeme buf
 941      in
 942      -- trace ("lex_id32 "{-++unpackFS lexeme-}) $
 943      case expandWhile# is_ident start_new_lexeme of { buf1 ->
 944      if emptyLexeme buf1
 945             then just_a_conid
 946             else
 947
 948      case slurp_trailing_hashes buf1 exts of { buf' ->
 949
 950      let
 951       lexeme      = lexemeToFastString buf'
 952       new_buf     = mergeLexemes buf buf'
 953       is_a_qvarid = cont (mk_qvar_token mod lexeme) new_buf
 954      in
 955      case _scc_ "haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
 956             Nothing          -> is_a_qvarid ;
 957
 958             Just kwd_token | isSpecial kwd_token   -- special ids (as, qualified, hiding) shouldn't be
 959                            -> is_a_qvarid          --  recognised as keywords here.
 960                            | otherwise
 961                            -> just_a_conid         -- avoid M.where etc.
 962      }}}
 963
 964 slurp_trailing_hashes buf exts
 965   | glaExtsEnabled exts = expandWhile# (`eqChar#` '#'#) buf
 966   | otherwise           = buf
 967
 968
 969 mk_var_token pk_str
 970   | is_upper f          = ITconid pk_str
 971   | is_ident f          = ITvarid pk_str
 972   | f `eqChar#` ':'#    = ITconsym pk_str
 973   | otherwise           = ITvarsym pk_str
 974   where
 975       (C# f) = _HEAD_ pk_str
 976       -- tl     = _TAIL_ pk_str
 977
 978 mk_qvar_token m token =
 979 -- trace ("mk_qvar ") $
 980  case mk_var_token token of
 981    ITconid n  -> ITqconid  (m,n)
 982    ITvarid n  -> ITqvarid  (m,n)
 983    ITconsym n -> ITqconsym (m,n)
 984    ITvarsym n -> ITqvarsym (m,n)
 985    _          -> ITunknown (show token)
 986 \end{code}
 987
 988 ----------------------------------------------------------------------------
 989 Horrible stuff for dealing with M.(,,,)
 990
 991 \begin{code}
 992 lex_tuple cont mod buf back_off =
 993   go 2 buf
 994   where
 995    go n buf =
 996     case currentChar# buf of
 997       ','# -> go (n+1) (stepOn buf)
 998       ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Boxed n))) (stepOn buf)
 999       _    -> back_off
1000
1001 lex_ubx_tuple cont mod buf back_off =
1002   go 2 buf
1003   where
1004    go n buf =
1005     case currentChar# buf of
1006       ','# -> go (n+1) (stepOn buf)
1007       '#'# -> case lookAhead# buf 1# of
1008                 ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Unboxed n)))
1009                                  (stepOnBy# buf 2#)
1010                 _    -> back_off
1011       _    -> back_off
1012 \end{code}
1013
1014 -----------------------------------------------------------------------------
1015
1016 \begin{code}
1017 data LayoutContext
1018   = NoLayout
1019   | Layout Int#
1020
1021 data ParseResult a
1022   = POk PState a
1023   | PFailed Message
1024
1025 data PState = PState {
1026         loc        :: SrcLoc,
1027         extsBitmap :: Int#,     -- bitmap that determines permitted extensions
1028         bol        :: Int#,
1029         atbol      :: Int#,
1030         context    :: [LayoutContext]
1031      }
1032
1033 type P a = StringBuffer         -- Input string
1034         -> PState
1035         -> ParseResult a
1036
1037 returnP   :: a -> P a
1038 returnP a buf s = POk s a
1039
1040 thenP      :: P a -> (a -> P b) -> P b
1041 m `thenP` k = \ buf s ->
1042         case m buf s of
1043                 POk s1 a -> k a buf s1
1044                 PFailed err  -> PFailed err
1045
1046 thenP_     :: P a -> P b -> P b
1047 m `thenP_` k = m `thenP` \_ -> k
1048
1049 mapP :: (a -> P b) -> [a] -> P [b]
1050 mapP f [] = returnP []
1051 mapP f (a:as) =
1052      f a `thenP` \b ->
1053      mapP f as `thenP` \bs ->
1054      returnP (b:bs)
1055
1056 failP :: String -> P a
1057 failP msg buf s = PFailed (text msg)
1058
1059 failMsgP :: Message -> P a
1060 failMsgP msg buf s = PFailed msg
1061
1062 lexError :: String -> P a
1063 lexError str buf s@PState{ loc = loc }
1064   = failMsgP (hcat [ppr loc, text ": ", text str]) buf s
1065
1066 getSrcLocP :: P SrcLoc
1067 getSrcLocP buf s@(PState{ loc = loc }) = POk s loc
1068
1069 -- use a temporary SrcLoc for the duration of the argument
1070 setSrcLocP :: SrcLoc -> P a -> P a
1071 setSrcLocP new_loc p buf s =
1072   case p buf s{ loc=new_loc } of
1073       POk _ a   -> POk s a
1074       PFailed e -> PFailed e
1075
1076 getSrcFile :: P FAST_STRING
1077 getSrcFile buf s@(PState{ loc = loc }) = POk s (srcLocFile loc)
1078
1079 pushContext :: LayoutContext -> P ()
1080 pushContext ctxt buf s@(PState{ context = ctx }) = POk s{context = ctxt:ctx} ()
1081
1082 {-
1083
1084 This special case in layoutOn is to handle layout contexts with are
1085 indented the same or less than the current context.  This is illegal
1086 according to the Haskell spec, so we have to arrange to close the
1087 current context.  eg.
1088
1089 class Foo a where
1090 class Bar a
1091
1092 after the first 'where', the sequence of events is:
1093
1094         - layout system inserts a ';' (column 0)
1095         - parser begins a new context at column 0
1096         - parser shifts ';' (legal empty declaration)
1097         - parser sees 'class': parse error (we're still in the inner context)
1098
1099 trouble is, by the time we know we need a new context, the lexer has
1100 already generated the ';'.  Hacky solution is as follows: since we
1101 know the column of the next token (it's the column number of the new
1102 context), we set the ACTUAL column number of the new context to this
1103 numer plus one.  Hence the next time the lexer is called, a '}' will
1104 be generated to close the new context straight away.  Furthermore, we
1105 have to set the atbol flag so that the ';' that the parser shifted as
1106 part of the new context is re-generated.
1107
1108 when the new context is *less* indented than the current one:
1109
1110 f = f where g = g where
1111 h = h
1112
1113         - current context: column 12.
1114         - on seeing 'h' (column 0), the layout system inserts '}'
1115         - parser starts a new context, column 0
1116         - parser sees '}', uses it to close new context
1117         - we still need to insert another '}' followed by a ';',
1118           hence the atbol trick.
1119
1120 There's also a special hack in here to deal with
1121
1122         do
1123            ....
1124            e $ do
1125            blah
1126
1127 i.e. the inner context is at the same indentation level as the outer
1128 context.  This is strictly illegal according to Haskell 98, but
1129 there's a lot of existing code using this style and it doesn't make
1130 any sense to disallow it, since empty 'do' lists don't make sense.
1131 -}
1132
1133 layoutOn :: Bool -> P ()
1134 layoutOn strict buf s@(PState{ bol = bol, context = ctx }) =
1135     let offset = lexemeIndex buf -# bol in
1136     case ctx of
1137         Layout prev_off : _
1138            | if strict then prev_off >=# offset else prev_off ># offset ->
1139                 --trace ("layout on, column: " ++  show (I# offset)) $
1140                 POk s{ context = Layout (offset +# 1#) : ctx, atbol = 1# } ()
1141         other ->
1142                 --trace ("layout on, column: " ++  show (I# offset)) $
1143                 POk s{ context = Layout offset : ctx } ()
1144
1145 layoutOff :: P ()
1146 layoutOff buf s@(PState{ context = ctx }) =
1147     POk s{ context = NoLayout:ctx } ()
1148
1149 popContext :: P ()
1150 popContext = \ buf s@(PState{ context = ctx, loc = loc }) ->
1151   case ctx of
1152         (_:tl) -> POk s{ context = tl } ()
1153         []     -> PFailed (srcParseErr buf loc)
1154
1155 -- for reasons of efficiency, flags indicating language extensions (eg,
1156 -- -fglasgow-exts or -fparr) are represented by a bitmap stored in an unboxed
1157 -- integer
1158
1159 glaExtsBit, ffiBit, parrBit :: Int
1160 glaExtsBit = 0
1161 ffiBit     = 1  -- FIXME: not used yet; still part of `glaExtsBit'
1162 parrBit    = 2
1163
1164 glaExtsEnabled, ffiEnabled, parrEnabled :: Int# -> Bool
1165 glaExtsEnabled flags = testBit (toInt32 flags) glaExtsBit
1166 ffiEnabled     flags = testBit (toInt32 flags) ffiBit
1167 parrEnabled    flags = testBit (toInt32 flags) parrBit
1168
1169 toInt32 :: Int# -> Int32
1170 toInt32 x# = fromIntegral (I# x#)
1171
1172 -- convenient record-based bitmap for the interface to the rest of the world
1173 --
1174 data ExtFlags = ExtFlags {
1175                   glasgowExtsEF :: Bool,
1176 --                ffiEF         :: Bool,  -- commented out to avoid warnings
1177                   parrEF        :: Bool   -- while not used yet
1178                 }
1179
1180 -- create a parse state
1181 --
1182 mkPState          :: SrcLoc -> ExtFlags -> PState
1183 mkPState loc exts  = PState {
1184                        loc        = loc,
1185                        extsBitmap = case (fromIntegral bitmap) of {I# bits -> bits},
1186                        bol        = 0#,
1187                        atbol      = 1#,
1188                        context    = []
1189                      }
1190                      where
1191                        bitmap =     glaExtsBit `setBitIf` glasgowExtsEF exts
1192 --                              .|. ffiBit     `setBitIf` ffiEF         exts
1193                                 .|. parrBit    `setBitIf` parrEF        exts
1194                        --
1195                        setBitIf :: Int -> Bool -> Int32
1196                        b `setBitIf` cond | cond      = bit b
1197                                          | otherwise = 0
1198
1199 -----------------------------------------------------------------------------
1200
1201 srcParseErr :: StringBuffer -> SrcLoc -> Message
1202 srcParseErr s l
1203   = hcat [ppr l,
1204           if null token
1205              then ptext SLIT(": parse error (possibly incorrect indentation)")
1206              else hcat [ptext SLIT(": parse error on input "),
1207                         char '`', text token, char '\'']
1208     ]
1209   where
1210         token = lexemeToString s
1211
1212 \end{code}