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