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