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 -- IMPORTANT: Keep this in synch with ParseIface.y's var_fs production! (SUP)
 281 ghcExtensionKeywordsFM = listToUFM $
 282         map (\ (x,y) -> (_PK_ x,y))
 283      [  ( "forall",     ITforall ),
 284         ( "foreign",    ITforeign ),
 285         ( "export",     ITexport ),
 286         ( "label",      ITlabel ),
 287         ( "dynamic",    ITdynamic ),
 288         ( "unsafe",     ITunsafe ),
 289         ( "with",       ITwith ),
 290         ( "stdcall",    ITstdcallconv),
 291         ( "ccall",      ITccallconv),
 292         ("_ccall_",     ITccall (False, False, False)),
 293         ("_ccall_GC_",  ITccall (False, False, True)),
 294         ("_casm_",      ITccall (False, True,  False)),
 295         ("_casm_GC_",   ITccall (False, True,  True)),
 296
 297         -- interface keywords
 298         ("__interface",         ITinterface),
 299         ("__expr",              ITexpr),
 300         ("__export",            IT__export),
 301         ("__depends",           ITdepends),
 302         ("__forall",            IT__forall),
 303         ("__letrec",            ITletrec),
 304         ("__coerce",            ITcoerce),
 305         ("__inline_me",         ITinlineMe),
 306         ("__inline_call",       ITinlineCall),
 307         ("__depends",           ITdepends),
 308         ("__DEFAULT",           ITdefaultbranch),
 309         ("__bot",               ITbottom),
 310         ("__integer",           ITinteger_lit),
 311         ("__float",             ITfloat_lit),
 312         ("__int64",             ITint64_lit),
 313         ("__word",              ITword_lit),
 314         ("__word64",            ITword64_lit),
 315         ("__rational",          ITrational_lit),
 316         ("__addr",              ITaddr_lit),
 317         ("__label",             ITlabel_lit),
 318         ("__litlit",            ITlit_lit),
 319         ("__string",            ITstring_lit),
 320         ("__a",                 ITtypeapp),
 321         ("__u",                 ITusage),
 322         ("__fuall",             ITfuall),
 323         ("__A",                 ITarity),
 324         ("__P",                 ITspecialise),
 325         ("__C",                 ITnocaf),
 326         ("__R",                 ITrules),
 327         ("__D",                 ITdeprecated),
 328         ("__U",                 ITunfold NoInlinePragInfo),
 329
 330         ("__ccall",             ITccall (False, False, False)),
 331         ("__ccall_GC",          ITccall (False, False, True)),
 332         ("__dyn_ccall",         ITccall (True,  False, False)),
 333         ("__dyn_ccall_GC",      ITccall (True,  False, True)),
 334         ("__casm",              ITccall (False, True,  False)),
 335         ("__dyn_casm",          ITccall (True,  True,  False)),
 336         ("__casm_GC",           ITccall (False, True,  True)),
 337         ("__dyn_casm_GC",       ITccall (True,  True,  True)),
 338
 339         ("/\\",                 ITbiglam)
 340      ]
 341
 342
 343 haskellKeySymsFM = listToUFM $
 344         map (\ (x,y) -> (_PK_ x,y))
 345       [ ("..",          ITdotdot)
 346        ,("::",          ITdcolon)
 347        ,("=",           ITequal)
 348        ,("\\",          ITlam)
 349        ,("|",           ITvbar)
 350        ,("<-",          ITlarrow)
 351        ,("->",          ITrarrow)
 352        ,("@",           ITat)
 353        ,("~",           ITtilde)
 354        ,("=>",          ITdarrow)
 355        ,("-",           ITminus)
 356        ,("!",           ITbang)
 357        ,(".",           ITdot)          -- sadly, for 'forall a . t'
 358        ]
 359 \end{code}
 360
 361 -----------------------------------------------------------------------------
 362 The lexical analyser
 363
 364 Lexer state:
 365
 366         - (glaexts) lexing an interface file or -fglasgow-exts
 367         - (bol)   pointer to beginning of line (for column calculations)
 368         - (buf)   pointer to beginning of token
 369         - (buf)   pointer to current char
 370         - (atbol) flag indicating whether we're at the beginning of a line
 371
 372 \begin{code}
 373 lexer :: (Token -> P a) -> P a
 374 lexer cont buf s@(PState{
 375                     loc = loc,
 376                     glasgow_exts = glaexts,
 377                     bol = bol,
 378                     atbol = atbol,
 379                     context = ctx
 380                 })
 381
 382         -- first, start a new lexeme and lose all the whitespace
 383   =  _scc_ "Lexer"
 384   tab line bol atbol (stepOverLexeme buf)
 385   where
 386         line = srcLocLine loc
 387
 388         tab y bol atbol buf = -- trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $
 389           case currentChar# buf of
 390
 391             '\NUL'# ->
 392                    if bufferExhausted (stepOn buf)
 393                         then cont ITeof buf s'
 394                         else trace "lexer: misplaced NUL?" $
 395                              tab y bol atbol (stepOn buf)
 396
 397             '\n'# -> let buf' = stepOn buf
 398                      in tab (y +# 1#) (currentIndex# buf') 1# buf'
 399
 400                 -- find comments.  This got harder in Haskell 98.
 401             '-'# ->  let trundle n =
 402                           let next = lookAhead# buf n in
 403                           if next `eqChar#` '-'# then trundle (n +# 1#)
 404                           else if is_symbol next || n <# 2#
 405                                 then is_a_token
 406                                 else tab y bol atbol
 407                                          (stepOnUntilChar# (stepOnBy# buf n) '\n'#)
 408                     in trundle 1#
 409
 410                 -- comments and pragmas.  We deal with LINE pragmas here,
 411                 -- and throw out any unrecognised pragmas as comments.  Any
 412                 -- pragmas we know about are dealt with later (after any layout
 413                 -- processing if necessary).
 414             '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
 415                 if lookAhead# buf 2# `eqChar#` '#'# then
 416                   if lookAhead# buf 3# `eqChar#` '#'# then is_a_token else
 417                   case expandWhile# is_space (setCurrentPos# buf 3#) of { buf1->
 418                   case expandWhile# is_ident (stepOverLexeme buf1)   of { buf2->
 419                   let lexeme = mkFastString -- ToDo: too slow
 420                                   (map toUpper (lexemeToString buf2)) in
 421                   case lookupUFM pragmaKeywordsFM lexeme of
 422                         Just ITline_prag ->
 423                            line_prag skip_to_end buf2 s'
 424                         Just other -> is_a_token
 425                         Nothing -> skip_to_end (stepOnBy# buf 2#) s'
 426                   }}
 427
 428                 else skip_to_end (stepOnBy# buf 2#) s'
 429                 where
 430                     skip_to_end = nested_comment (lexer cont)
 431
 432                 -- special GHC extension: we grok cpp-style #line pragmas
 433             '#'# | lexemeIndex buf ==# bol ->   -- the '#' must be in column 0
 434                 line_prag next_line (stepOn buf) s'
 435                 where
 436                 next_line buf = lexer cont (stepOnUntilChar# buf '\n'#)
 437
 438                 -- tabs have been expanded beforehand
 439             c | is_space c -> tab y bol atbol (stepOn buf)
 440               | otherwise  -> is_a_token
 441
 442            where s' = s{loc = replaceSrcLine loc y,
 443                         bol = bol,
 444                        atbol = atbol}
 445
 446                  is_a_token | atbol /=# 0# = lexBOL cont buf s'
 447                             | otherwise    = lexToken cont glaexts buf s'
 448
 449 -- {-# LINE .. #-} pragmas.  yeuch.
 450 line_prag cont buf s@PState{loc=loc} =
 451   case expandWhile# is_space buf                of { buf1 ->
 452   case scanNumLit 0 (stepOverLexeme buf1)       of { (line,buf2) ->
 453   -- subtract one: the line number refers to the *following* line.
 454   let real_line = line - 1 in
 455   case fromInteger real_line                    of { i@(I# l) ->
 456         -- ToDo, if no filename then we skip the newline.... d'oh
 457   case expandWhile# is_space buf2               of { buf3 ->
 458   case currentChar# buf3                        of
 459      '\"'#{-"-} ->
 460         case untilEndOfString# (stepOn (stepOverLexeme buf3)) of { buf4 ->
 461         let
 462             file = lexemeToFastString buf4
 463             new_buf = stepOn (stepOverLexeme buf4)
 464         in
 465         if nullFastString file
 466                 then cont new_buf s{loc = replaceSrcLine loc l}
 467                 else cont new_buf s{loc = mkSrcLoc file i}
 468         }
 469      _other -> cont (stepOverLexeme buf3) s{loc = replaceSrcLine loc l}
 470   }}}}
 471
 472 nested_comment :: P a -> P a
 473 nested_comment cont buf = loop buf
 474  where
 475    loop buf =
 476      case currentChar# buf of
 477         '\NUL'# | bufferExhausted (stepOn buf) ->
 478                 lexError "unterminated `{-'" buf -- -}
 479         '-'# | lookAhead# buf 1# `eqChar#` '}'# ->
 480                 cont (stepOnBy# buf 2#)
 481
 482         '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
 483               nested_comment (nested_comment cont) (stepOnBy# buf 2#)
 484
 485         '\n'# -> \ s@PState{loc=loc} ->
 486                  let buf' = stepOn buf in
 487                  nested_comment cont buf'
 488                         s{loc = incSrcLine loc, bol = currentIndex# buf',
 489                           atbol = 1#}
 490
 491         _   -> nested_comment cont (stepOn buf)
 492
 493 -- When we are lexing the first token of a line, check whether we need to
 494 -- insert virtual semicolons or close braces due to layout.
 495
 496 lexBOL :: (Token -> P a) -> P a
 497 lexBOL cont buf s@(PState{
 498                     loc = loc,
 499                     glasgow_exts = glaexts,
 500                     bol = bol,
 501                     atbol = atbol,
 502                     context = ctx
 503                   }) =
 504         if need_close_curly then
 505                 --trace ("col = " ++ show (I# col) ++ ", layout: inserting '}'") $
 506                 cont ITvccurly buf s{atbol = 1#, context = tail ctx}
 507         else if need_semi_colon then
 508                 --trace ("col = " ++ show (I# col) ++ ", layout: inserting ';'") $
 509                 cont ITsemi buf s{atbol = 0#}
 510         else
 511                 lexToken cont glaexts buf s{atbol = 0#}
 512   where
 513         col = currentIndex# buf -# bol
 514
 515         need_close_curly =
 516                 case ctx of
 517                         [] -> False
 518                         (i:_) -> case i of
 519                                     NoLayout -> False
 520                                     Layout n -> col <# n
 521         need_semi_colon =
 522                 case ctx of
 523                         [] -> False
 524                         (i:_) -> case i of
 525                                     NoLayout -> False
 526                                     Layout n -> col ==# n
 527
 528
 529 lexToken :: (Token -> P a) -> Int# -> P a
 530 lexToken cont glaexts buf =
 531  -- trace "lexToken" $
 532   case currentChar# buf of
 533
 534     -- special symbols ----------------------------------------------------
 535     '('# | flag glaexts && lookAhead# buf 1# `eqChar#` '#'#
 536                 -> cont IToubxparen (setCurrentPos# buf 2#)
 537          | otherwise
 538                 -> cont IToparen (incLexeme buf)
 539
 540     ')'# -> cont ITcparen    (incLexeme buf)
 541     '['# -> cont ITobrack    (incLexeme buf)
 542     ']'# -> cont ITcbrack    (incLexeme buf)
 543     ','# -> cont ITcomma     (incLexeme buf)
 544     ';'# -> cont ITsemi      (incLexeme buf)
 545     '}'# -> \ s@PState{context = ctx} ->
 546             case ctx of
 547                 (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'}
 548                 _        -> lexError "too many '}'s" buf s
 549     '|'# -> case lookAhead# buf 1# of
 550                  '}'#  | flag glaexts -> cont ITccurlybar
 551                                               (setCurrentPos# buf 2#)
 552                  _                    -> lex_sym cont (incLexeme buf)
 553
 554
 555     '#'# -> case lookAhead# buf 1# of
 556                 ')'#  | flag glaexts -> cont ITcubxparen (setCurrentPos# buf 2#)
 557                 '-'# -> case lookAhead# buf 2# of
 558                            '}'# -> cont ITclose_prag (setCurrentPos# buf 3#)
 559                            _    -> lex_sym cont (incLexeme buf)
 560                 _    -> lex_sym cont (incLexeme buf)
 561
 562     '`'# | flag glaexts && lookAhead# buf 1# `eqChar#` '`'#
 563                 -> lex_cstring cont (setCurrentPos# buf 2#)
 564          | otherwise
 565                 -> cont ITbackquote (incLexeme buf)
 566
 567     '{'# ->     -- look for "{-##" special iface pragma
 568             case lookAhead# buf 1# of
 569            '|'# | flag glaexts
 570                 -> cont ITocurlybar (setCurrentPos# buf 2#)
 571            '-'# -> case lookAhead# buf 2# of
 572                     '#'# -> case lookAhead# buf 3# of
 573                                 '#'# ->
 574                                    let (lexeme, buf')
 575                                           = doDiscard False (stepOnBy# (stepOverLexeme buf) 4#) in
 576                                             cont (ITpragma lexeme) buf'
 577                                 _ -> lex_prag cont (setCurrentPos# buf 3#)
 578                     _    -> cont ITocurly (incLexeme buf)
 579            _ -> (layoutOff `thenP_` cont ITocurly)  (incLexeme buf)
 580
 581     -- strings/characters -------------------------------------------------
 582     '\"'#{-"-} -> lex_string cont glaexts [] (incLexeme buf)
 583     '\''#      -> lex_char (char_end cont) glaexts (incLexeme buf)
 584
 585     -- strictness and cpr pragmas and __scc treated specially.
 586     '_'# | flag glaexts ->
 587          case lookAhead# buf 1# of
 588            '_'# -> case lookAhead# buf 2# of
 589                     'S'# ->
 590                         lex_demand cont (stepOnUntil (not . isSpace)
 591                                         (stepOnBy# buf 3#)) -- past __S
 592                     'M'# ->
 593                         cont ITcprinfo (stepOnBy# buf 3#)       -- past __M
 594
 595                     's'# ->
 596                         case prefixMatch (stepOnBy# buf 3#) "cc" of
 597                                Just buf' -> lex_scc cont (stepOverLexeme buf')
 598                                Nothing   -> lex_id cont glaexts buf
 599                     _ -> lex_id cont glaexts buf
 600            _    -> lex_id cont glaexts buf
 601
 602         -- Hexadecimal and octal constants
 603     '0'# | (ch `eqChar#` 'x'# || ch `eqChar#` 'X'#) && is_hexdigit ch2
 604                 -> readNum (after_lexnum cont glaexts) buf' is_hexdigit 16 hex
 605          | (ch `eqChar#` 'o'# || ch `eqChar#` 'O'#) && is_octdigit ch2
 606                 -> readNum (after_lexnum cont glaexts) buf' is_octdigit  8 oct_or_dec
 607         where ch   = lookAhead# buf 1#
 608               ch2  = lookAhead# buf 2#
 609               buf' = setCurrentPos# buf 2#
 610
 611     '\NUL'# ->
 612             if bufferExhausted (stepOn buf) then
 613                cont ITeof buf
 614             else
 615                trace "lexIface: misplaced NUL?" $
 616                cont (ITunknown "\NUL") (stepOn buf)
 617
 618     '?'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
 619             lex_ip cont (incLexeme buf)
 620     c | is_digit  c -> lex_num cont glaexts 0 buf
 621       | is_symbol c -> lex_sym cont buf
 622       | is_upper  c -> lex_con cont glaexts buf
 623       | is_ident  c -> lex_id  cont glaexts buf
 624       | otherwise   -> lexError "illegal character" buf
 625
 626 -- Int# is unlifted, and therefore faster than Bool for flags.
 627 {-# INLINE flag #-}
 628 flag :: Int# -> Bool
 629 flag 0# = False
 630 flag _  = True
 631
 632 -------------------------------------------------------------------------------
 633 -- Pragmas
 634
 635 lex_prag cont buf
 636   = case expandWhile# is_space buf of { buf1 ->
 637     case expandWhile# is_ident (stepOverLexeme buf1) of { buf2 ->
 638     let lexeme = mkFastString (map toUpper (lexemeToString buf2)) in
 639     case lookupUFM pragmaKeywordsFM lexeme of
 640         Just kw -> cont kw (mergeLexemes buf buf2)
 641         Nothing -> panic "lex_prag"
 642   }}
 643
 644 -------------------------------------------------------------------------------
 645 -- Strings & Chars
 646
 647 lex_string cont glaexts s buf
 648   = case currentChar# buf of
 649         '"'#{-"-} ->
 650            let buf' = incLexeme buf; s' = mkFastStringInt (reverse s) in
 651            case currentChar# buf' of
 652                 '#'# | flag glaexts -> if all (<= 0xFF) s
 653                     then cont (ITprimstring s') (incLexeme buf')
 654                     else lexError "primitive string literal must contain only characters <= '\xFF'" buf'
 655                 _                   -> cont (ITstring s') buf'
 656
 657         -- ignore \& in a string, deal with string gaps
 658         '\\'# | next_ch `eqChar#` '&'#
 659                 -> lex_string cont glaexts s buf'
 660               | is_space next_ch
 661                 -> lex_stringgap cont glaexts s (incLexeme buf)
 662
 663             where next_ch = lookAhead# buf 1#
 664                   buf' = setCurrentPos# buf 2#
 665
 666         _ -> lex_char (lex_next_string cont s) glaexts buf
 667
 668 lex_stringgap cont glaexts s buf
 669   = let buf' = incLexeme buf in
 670     case currentChar# buf of
 671         '\n'# -> \st@PState{loc = loc} -> lex_stringgap cont glaexts s buf'
 672                   st{loc = incSrcLine loc}
 673         '\\'# -> lex_string cont glaexts s buf'
 674         c | is_space c -> lex_stringgap cont glaexts s buf'
 675         other -> charError buf'
 676
 677 lex_next_string cont s glaexts c buf = lex_string cont glaexts (c:s) buf
 678
 679 lex_char :: (Int# -> Int -> P a) -> Int# -> P a
 680 lex_char cont glaexts buf
 681   = case currentChar# buf of
 682         '\\'# -> lex_escape (cont glaexts) (incLexeme buf)
 683         c | is_any c -> cont glaexts (I# (ord# c)) (incLexeme buf)
 684         other -> charError buf
 685
 686 char_end cont glaexts c buf
 687   = case currentChar# buf of
 688         '\''# -> let buf' = incLexeme buf in
 689                  case currentChar# buf' of
 690                         '#'# | flag glaexts
 691                                 -> cont (ITprimchar c) (incLexeme buf')
 692                         _       -> cont (ITchar c) buf'
 693         _     -> charError buf
 694
 695 lex_escape cont buf
 696   = let buf' = incLexeme buf in
 697     case currentChar# buf of
 698         'a'#       -> cont (ord '\a') buf'
 699         'b'#       -> cont (ord '\b') buf'
 700         'f'#       -> cont (ord '\f') buf'
 701         'n'#       -> cont (ord '\n') buf'
 702         'r'#       -> cont (ord '\r') buf'
 703         't'#       -> cont (ord '\t') buf'
 704         'v'#       -> cont (ord '\v') buf'
 705         '\\'#      -> cont (ord '\\') buf'
 706         '"'#       -> cont (ord '\"') buf'
 707         '\''#      -> cont (ord '\'') buf'
 708         '^'#       -> let c = currentChar# buf' in
 709                       if c `geChar#` '@'# && c `leChar#` '_'#
 710                         then cont (I# (ord# c -# ord# '@'#)) (incLexeme buf')
 711                         else charError buf'
 712
 713         'x'#      -> readNum (after_charnum cont) buf' is_hexdigit 16 hex
 714         'o'#      -> readNum (after_charnum cont) buf' is_octdigit  8 oct_or_dec
 715         x | is_digit x
 716                   -> readNum (after_charnum cont) buf is_digit    10 oct_or_dec
 717
 718         _          -> case [ (c,buf2) | (p,c) <- silly_escape_chars,
 719                                        Just buf2 <- [prefixMatch buf p] ] of
 720                             (c,buf2):_ -> cont (ord c) buf2
 721                             [] -> charError buf'
 722
 723 after_charnum cont i buf
 724   = if i >= 0 && i <= 0x7FFFFFFF
 725         then cont (fromInteger i) buf
 726         else charError buf
 727
 728 readNum cont buf is_digit base conv = read buf 0
 729   where read buf i
 730           = case currentChar# buf of { c ->
 731             if is_digit c
 732                 then read (incLexeme buf) (i*base + (toInteger (I# (conv c))))
 733                 else cont i buf
 734             }
 735
 736 is_hexdigit c
 737         =  is_digit c
 738         || (c `geChar#` 'a'# && c `leChar#` 'f'#)
 739         || (c `geChar#` 'A'# && c `leChar#` 'F'#)
 740
 741 hex c | is_digit c = ord# c -# ord# '0'#
 742       | otherwise  = ord# (to_lower c) -# ord# 'a'# +# 10#
 743 oct_or_dec c = ord# c -# ord# '0'#
 744
 745 is_octdigit c = c `geChar#` '0'# && c `leChar#` '7'#
 746
 747 to_lower c
 748   | c `geChar#` 'A'# && c `leChar#` 'Z'#
 749         = chr# (ord# c -# (ord# 'A'# -# ord# 'a'#))
 750   | otherwise = c
 751
 752 charError buf = lexError "error in character literal" buf
 753
 754 silly_escape_chars = [
 755         ("NUL", '\NUL'),
 756         ("SOH", '\SOH'),
 757         ("STX", '\STX'),
 758         ("ETX", '\ETX'),
 759         ("EOT", '\EOT'),
 760         ("ENQ", '\ENQ'),
 761         ("ACK", '\ACK'),
 762         ("BEL", '\BEL'),
 763         ("BS", '\BS'),
 764         ("HT", '\HT'),
 765         ("LF", '\LF'),
 766         ("VT", '\VT'),
 767         ("FF", '\FF'),
 768         ("CR", '\CR'),
 769         ("SO", '\SO'),
 770         ("SI", '\SI'),
 771         ("DLE", '\DLE'),
 772         ("DC1", '\DC1'),
 773         ("DC2", '\DC2'),
 774         ("DC3", '\DC3'),
 775         ("DC4", '\DC4'),
 776         ("NAK", '\NAK'),
 777         ("SYN", '\SYN'),
 778         ("ETB", '\ETB'),
 779         ("CAN", '\CAN'),
 780         ("EM", '\EM'),
 781         ("SUB", '\SUB'),
 782         ("ESC", '\ESC'),
 783         ("FS", '\FS'),
 784         ("GS", '\GS'),
 785         ("RS", '\RS'),
 786         ("US", '\US'),
 787         ("SP", '\SP'),
 788         ("DEL", '\DEL')
 789         ]
 790
 791 -------------------------------------------------------------------------------
 792
 793 lex_demand cont buf =
 794  case read_em [] buf of { (ls,buf') ->
 795  case currentChar# buf' of
 796    'B'# -> cont (ITstrict (ls, True )) (incLexeme buf')
 797    _    -> cont (ITstrict (ls, False)) buf'
 798  }
 799  where
 800    -- code snatched from Demand.lhs
 801   read_em acc buf =
 802    case currentChar# buf of
 803     'L'# -> read_em (WwLazy False : acc) (stepOn buf)
 804     'A'# -> read_em (WwLazy True  : acc) (stepOn buf)
 805     'S'# -> read_em (WwStrict     : acc) (stepOn buf)
 806     'P'# -> read_em (WwPrim       : acc) (stepOn buf)
 807     'E'# -> read_em (WwEnum       : acc) (stepOn buf)
 808     ')'# -> (reverse acc, stepOn buf)
 809     'U'# -> do_unpack DataType True  acc (stepOnBy# buf 2#)
 810     'u'# -> do_unpack DataType False acc (stepOnBy# buf 2#)
 811     'N'# -> do_unpack NewType True  acc (stepOnBy# buf 2#)
 812     'n'# -> do_unpack NewType False acc (stepOnBy# buf 2#)
 813     _    -> (reverse acc, buf)
 814
 815   do_unpack new_or_data wrapper_unpacks acc buf
 816    = case read_em [] buf of
 817       (stuff, rest) -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
 818
 819
 820 ------------------
 821 lex_scc cont buf =
 822  case currentChar# buf of
 823   'C'# -> cont ITsccAllCafs (incLexeme buf)
 824   other -> cont ITscc buf
 825
 826 -----------------------------------------------------------------------------
 827 -- Numbers
 828
 829 lex_num :: (Token -> P a) -> Int# -> Integer -> P a
 830 lex_num cont glaexts acc buf =
 831  case scanNumLit acc buf of
 832      (acc',buf') ->
 833        case currentChar# buf' of
 834          '.'# | is_digit (lookAhead# buf' 1#) ->
 835              -- this case is not optimised at all, as the
 836              -- presence of floating point numbers in interface
 837              -- files is not that common. (ToDo)
 838             case expandWhile# is_digit (incLexeme buf') of
 839               buf2 -> -- points to first non digit char
 840
 841                 let l = case currentChar# buf2 of
 842                           'E'# -> do_exponent
 843                           'e'# -> do_exponent
 844                           _ -> buf2
 845
 846                     do_exponent
 847                         = let buf3 = incLexeme buf2 in
 848                           case currentChar# buf3 of
 849                                 '-'# -> expandWhile# is_digit (incLexeme buf3)
 850                                 '+'# -> expandWhile# is_digit (incLexeme buf3)
 851                                 x | is_digit x -> expandWhile# is_digit buf3
 852                                 _ -> buf2
 853
 854                     v = readRational__ (lexemeToString l)
 855
 856                 in case currentChar# l of -- glasgow exts only
 857                       '#'# | flag glaexts -> let l' = incLexeme l in
 858                               case currentChar# l' of
 859                                 '#'# -> cont (ITprimdouble v) (incLexeme l')
 860                                 _    -> cont (ITprimfloat  v) l'
 861                       _ -> cont (ITrational v) l
 862
 863          _ -> after_lexnum cont glaexts acc' buf'
 864
 865 after_lexnum cont glaexts i buf
 866   = case currentChar# buf of
 867         '#'# | flag glaexts -> cont (ITprimint i) (incLexeme buf)
 868         _    -> cont (ITinteger i) buf
 869
 870 -----------------------------------------------------------------------------
 871 -- C "literal literal"s  (i.e. things like ``NULL'', ``stdout'' etc.)
 872
 873 -- we lexemeToFastString on the bit between the ``''s, but include the
 874 -- quotes in the full lexeme.
 875
 876 lex_cstring cont buf =
 877  case expandUntilMatch (stepOverLexeme buf) "\'\'" of
 878    Just buf' -> cont (ITlitlit (lexemeToFastString
 879                                 (setCurrentPos# buf' (negateInt# 2#))))
 880                    (mergeLexemes buf buf')
 881    Nothing   -> lexError "unterminated ``" buf
 882
 883 -----------------------------------------------------------------------------
 884 -- identifiers, symbols etc.
 885
 886 lex_ip cont buf =
 887  case expandWhile# is_ident buf of
 888    buf' -> cont (ITipvarid lexeme) buf'
 889            where lexeme = lexemeToFastString buf'
 890
 891 lex_id cont glaexts buf =
 892  let buf1 = expandWhile# is_ident buf in
 893  seq buf1 $
 894
 895  case (if flag glaexts
 896         then expandWhile# (eqChar# '#'#) buf1 -- slurp trailing hashes
 897         else buf1)                              of { buf' ->
 898
 899  let lexeme  = lexemeToFastString buf' in
 900
 901  case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
 902         Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $
 903                           cont kwd_token buf';
 904         Nothing        ->
 905
 906  let var_token = cont (ITvarid lexeme) buf' in
 907
 908  if not (flag glaexts)
 909    then var_token
 910    else
 911
 912  case lookupUFM ghcExtensionKeywordsFM lexeme of {
 913         Just kwd_token -> cont kwd_token buf';
 914         Nothing        -> var_token
 915
 916  }}}
 917
 918 lex_sym cont buf =
 919  -- trace "lex_sym" $
 920  case expandWhile# is_symbol buf of
 921    buf' -> case lookupUFM haskellKeySymsFM lexeme of {
 922                 Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
 923                                   cont kwd_token buf' ;
 924                 Nothing        -> --trace ("sym: "++unpackFS lexeme) $
 925                                   cont (mk_var_token lexeme) buf'
 926            }
 927         where lexeme = lexemeToFastString buf'
 928
 929
 930 lex_con cont glaexts buf =
 931  -- trace ("con: "{-++unpackFS lexeme-}) $
 932  case expandWhile# is_ident buf          of { buf1 ->
 933  case slurp_trailing_hashes buf1 glaexts of { buf' ->
 934
 935  case currentChar# buf' of
 936      '.'# -> munch
 937      _    -> just_a_conid
 938
 939    where
 940     just_a_conid = cont (ITconid lexeme) buf'
 941     lexeme = lexemeToFastString buf'
 942     munch = lex_qid cont glaexts lexeme (incLexeme buf') just_a_conid
 943  }}
 944
 945 lex_qid cont glaexts mod buf just_a_conid =
 946  -- trace ("quid: "{-++unpackFS lexeme-}) $
 947  case currentChar# buf of
 948   '['# ->       -- Special case for []
 949     case lookAhead# buf 1# of
 950      ']'# -> cont (ITqconid  (mod,SLIT("[]"))) (setCurrentPos# buf 2#)
 951      _    -> just_a_conid
 952
 953   '('# ->  -- Special case for (,,,)
 954            -- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)"
 955     case lookAhead# buf 1# of
 956      '#'# | flag glaexts -> case lookAhead# buf 2# of
 957                 ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#)
 958                                 just_a_conid
 959                 _    -> just_a_conid
 960      ')'# -> cont (ITqconid (mod,SLIT("()"))) (setCurrentPos# buf 2#)
 961      ','# -> lex_tuple cont mod (setCurrentPos# buf 2#) just_a_conid
 962      _    -> just_a_conid
 963
 964   '-'# -> case lookAhead# buf 1# of
 965             '>'# -> cont (ITqconid (mod,SLIT("(->)"))) (setCurrentPos# buf 2#)
 966             _    -> lex_id3 cont glaexts mod buf just_a_conid
 967   _    -> lex_id3 cont glaexts mod buf just_a_conid
 968
 969 lex_id3 cont glaexts mod buf just_a_conid
 970   | is_symbol (currentChar# buf) =
 971      let
 972         start_new_lexeme = stepOverLexeme buf
 973      in
 974      -- trace ("lex_id31 "{-++unpackFS lexeme-}) $
 975      case expandWhile# is_symbol start_new_lexeme of { buf' ->
 976      let
 977        lexeme  = lexemeToFastString buf'
 978         -- real lexeme is M.<sym>
 979        new_buf = mergeLexemes buf buf'
 980      in
 981      cont (mk_qvar_token mod lexeme) new_buf
 982         -- wrong, but arguably morally right: M... is now a qvarsym
 983      }
 984
 985   | otherwise   =
 986      let
 987         start_new_lexeme = stepOverLexeme buf
 988      in
 989      -- trace ("lex_id32 "{-++unpackFS lexeme-}) $
 990      case expandWhile# is_ident start_new_lexeme of { buf1 ->
 991      if emptyLexeme buf1
 992             then just_a_conid
 993             else
 994
 995      case slurp_trailing_hashes buf1 glaexts of { buf' ->
 996
 997      let
 998       lexeme  = lexemeToFastString buf'
 999       new_buf = mergeLexemes buf buf'
1000       is_a_qvarid = cont (mk_qvar_token mod lexeme) new_buf
1001      in
1002      case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
1003             Just kwd_token -> just_a_conid; -- avoid M.where etc.
1004             Nothing        -> is_a_qvarid
1005         -- TODO: special ids (as, qualified, hiding) shouldn't be
1006         -- recognised as keywords here.  ie.  M.as is a qualified varid.
1007      }}}
1008
1009
1010 slurp_trailing_hashes buf glaexts
1011   | flag glaexts = expandWhile# (`eqChar#` '#'#) buf
1012   | otherwise    = buf
1013
1014
1015 mk_var_token pk_str
1016   | is_upper f          = ITconid pk_str
1017   | is_ident f          = ITvarid pk_str
1018   | f `eqChar#` ':'#    = ITconsym pk_str
1019   | otherwise           = ITvarsym pk_str
1020   where
1021       (C# f) = _HEAD_ pk_str
1022       -- tl     = _TAIL_ pk_str
1023
1024 mk_qvar_token m token =
1025 -- trace ("mk_qvar ") $
1026  case mk_var_token token of
1027    ITconid n  -> ITqconid  (m,n)
1028    ITvarid n  -> ITqvarid  (m,n)
1029    ITconsym n -> ITqconsym (m,n)
1030    ITvarsym n -> ITqvarsym (m,n)
1031    _          -> ITunknown (show token)
1032 \end{code}
1033
1034 ----------------------------------------------------------------------------
1035 Horrible stuff for dealing with M.(,,,)
1036
1037 \begin{code}
1038 lex_tuple cont mod buf back_off =
1039   go 2 buf
1040   where
1041    go n buf =
1042     case currentChar# buf of
1043       ','# -> go (n+1) (stepOn buf)
1044       ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Boxed n))) (stepOn buf)
1045       _    -> back_off
1046
1047 lex_ubx_tuple cont mod buf back_off =
1048   go 2 buf
1049   where
1050    go n buf =
1051     case currentChar# buf of
1052       ','# -> go (n+1) (stepOn buf)
1053       '#'# -> case lookAhead# buf 1# of
1054                 ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Unboxed n)))
1055                                  (stepOnBy# buf 2#)
1056                 _    -> back_off
1057       _    -> back_off
1058 \end{code}
1059
1060 -----------------------------------------------------------------------------
1061 doDiscard rips along really fast, looking for a '#-}',
1062 indicating the end of the pragma we're skipping
1063
1064 \begin{code}
1065 doDiscard inStr buf =
1066  case currentChar# buf of
1067    '#'# | not inStr ->
1068        case lookAhead# buf 1# of { '#'# ->
1069        case lookAhead# buf 2# of { '-'# ->
1070        case lookAhead# buf 3# of { '}'# ->
1071            (lexemeToBuffer buf, stepOverLexeme (setCurrentPos# buf 4#));
1072         _    -> doDiscard inStr (incLexeme buf) };
1073         _    -> doDiscard inStr (incLexeme buf) };
1074         _    -> doDiscard inStr (incLexeme buf) }
1075    '"'# ->
1076        let
1077         odd_slashes buf flg i# =
1078           case lookAhead# buf i# of
1079            '\\'# -> odd_slashes buf (not flg) (i# -# 1#)
1080            _     -> flg
1081        in
1082        case lookAhead# buf (negateInt# 1#) of --backwards, actually
1083          '\\'# -> -- escaping something..
1084            if odd_slashes buf True (negateInt# 2#) then
1085                -- odd number of slashes, " is escaped.
1086               doDiscard inStr (incLexeme buf)
1087            else
1088                -- even number of slashes, \ is escaped.
1089               doDiscard (not inStr) (incLexeme buf)
1090          _ -> case inStr of -- forced to avoid build-up
1091                True  -> doDiscard False (incLexeme buf)
1092                False -> doDiscard True  (incLexeme buf)
1093    _ -> doDiscard inStr (incLexeme buf)
1094
1095 \end{code}
1096
1097 -----------------------------------------------------------------------------
1098
1099 \begin{code}
1100 data LayoutContext
1101   = NoLayout
1102   | Layout Int#
1103
1104 data ParseResult a
1105   = POk PState a
1106   | PFailed Message
1107
1108 data PState = PState {
1109         loc           :: SrcLoc,
1110         glasgow_exts  :: Int#,
1111         bol           :: Int#,
1112         atbol         :: Int#,
1113         context       :: [LayoutContext]
1114      }
1115
1116 type P a = StringBuffer         -- Input string
1117         -> PState
1118         -> ParseResult a
1119
1120 returnP   :: a -> P a
1121 returnP a buf s = POk s a
1122
1123 thenP      :: P a -> (a -> P b) -> P b
1124 m `thenP` k = \ buf s ->
1125         case m buf s of
1126                 POk s1 a -> k a buf s1
1127                 PFailed err  -> PFailed err
1128
1129 thenP_     :: P a -> P b -> P b
1130 m `thenP_` k = m `thenP` \_ -> k
1131
1132 mapP :: (a -> P b) -> [a] -> P [b]
1133 mapP f [] = returnP []
1134 mapP f (a:as) =
1135      f a `thenP` \b ->
1136      mapP f as `thenP` \bs ->
1137      returnP (b:bs)
1138
1139 failP :: String -> P a
1140 failP msg buf s = PFailed (text msg)
1141
1142 failMsgP :: Message -> P a
1143 failMsgP msg buf s = PFailed msg
1144
1145 lexError :: String -> P a
1146 lexError str buf s@PState{ loc = loc }
1147   = failMsgP (hcat [ppr loc, text ": ", text str]) buf s
1148
1149 getSrcLocP :: P SrcLoc
1150 getSrcLocP buf s@(PState{ loc = loc }) = POk s loc
1151
1152 getSrcFile :: P FAST_STRING
1153 getSrcFile buf s@(PState{ loc = loc }) = POk s (srcLocFile loc)
1154
1155 getContext :: P [LayoutContext]
1156 getContext buf s@(PState{ context = ctx }) = POk s ctx
1157
1158 pushContext :: LayoutContext -> P ()
1159 pushContext ctxt buf s@(PState{ context = ctx }) = POk s{context = ctxt:ctx} ()
1160
1161 {-
1162
1163 This special case in layoutOn is to handle layout contexts with are
1164 indented the same or less than the current context.  This is illegal
1165 according to the Haskell spec, so we have to arrange to close the
1166 current context.  eg.
1167
1168 class Foo a where
1169 class Bar a
1170
1171 after the first 'where', the sequence of events is:
1172
1173         - layout system inserts a ';' (column 0)
1174         - parser begins a new context at column 0
1175         - parser shifts ';' (legal empty declaration)
1176         - parser sees 'class': parse error (we're still in the inner context)
1177
1178 trouble is, by the time we know we need a new context, the lexer has
1179 already generated the ';'.  Hacky solution is as follows: since we
1180 know the column of the next token (it's the column number of the new
1181 context), we set the ACTUAL column number of the new context to this
1182 numer plus one.  Hence the next time the lexer is called, a '}' will
1183 be generated to close the new context straight away.  Furthermore, we
1184 have to set the atbol flag so that the ';' that the parser shifted as
1185 part of the new context is re-generated.
1186
1187 when the new context is *less* indented than the current one:
1188
1189 f = f where g = g where
1190 h = h
1191
1192         - current context: column 12.
1193         - on seeing 'h' (column 0), the layout system inserts '}'
1194         - parser starts a new context, column 0
1195         - parser sees '}', uses it to close new context
1196         - we still need to insert another '}' followed by a ';',
1197           hence the atbol trick.
1198
1199 There's also a special hack in here to deal with
1200
1201         do
1202            ....
1203            e $ do
1204            blah
1205
1206 i.e. the inner context is at the same indentation level as the outer
1207 context.  This is strictly illegal according to Haskell 98, but
1208 there's a lot of existing code using this style and it doesn't make
1209 any sense to disallow it, since empty 'do' lists don't make sense.
1210 -}
1211
1212 layoutOn :: Bool -> P ()
1213 layoutOn strict buf s@(PState{ bol = bol, context = ctx }) =
1214     let offset = lexemeIndex buf -# bol in
1215     case ctx of
1216         Layout prev_off : _
1217            | if strict then prev_off >=# offset else prev_off ># offset ->
1218                 --trace ("layout on, column: " ++  show (I# offset)) $
1219                 POk s{ context = Layout (offset +# 1#) : ctx, atbol = 1# } ()
1220         other ->
1221                 --trace ("layout on, column: " ++  show (I# offset)) $
1222                 POk s{ context = Layout offset : ctx } ()
1223
1224 layoutOff :: P ()
1225 layoutOff buf s@(PState{ context = ctx }) =
1226     POk s{ context = NoLayout:ctx } ()
1227
1228 popContext :: P ()
1229 popContext = \ buf s@(PState{ context = ctx, loc = loc }) ->
1230   case ctx of
1231         (_:tl) -> POk s{ context = tl } ()
1232         []     -> PFailed (srcParseErr buf loc)
1233
1234 {-
1235  Note that if the name of the file we're processing ends
1236  with `hi-boot', we accept it on faith as having the right
1237  version. This is done so that .hi-boot files that comes
1238  with hsc don't have to be updated before every release,
1239  *and* it allows us to share .hi-boot files with versions
1240  of hsc that don't have .hi version checking (e.g., ghc-2.10's)
1241
1242  If the version number is 0, the checking is also turned off.
1243  (needed to deal with GHC.hi only!)
1244
1245  Once we can assume we're compiling with a version of ghc that
1246  supports interface file checking, we can drop the special
1247  pleading
1248 -}
1249 checkVersion :: Maybe Integer -> P ()
1250 checkVersion mb@(Just v) buf s@(PState{loc = loc})
1251  | (v==0) || (v == fromInt opt_HiVersion) || opt_NoHiCheck = POk s ()
1252  | otherwise = PFailed (ifaceVersionErr mb loc ([]::[Token]){-Todo-})
1253 checkVersion mb@Nothing  buf s@(PState{loc = loc})
1254  | "hi-boot" `isSuffixOf` (_UNPK_ (srcLocFile loc)) = POk s ()
1255  | otherwise = PFailed (ifaceVersionErr mb loc ([]::[Token]){-Todo-})
1256
1257 -----------------------------------------------------------------
1258
1259 ifaceParseErr :: StringBuffer -> SrcLoc -> Message
1260 ifaceParseErr s l
1261   = hsep [ppr l, ptext SLIT("Interface file parse error; on input `"),
1262           text (lexemeToString s), char '\'']
1263
1264 ifaceVersionErr hi_vers l toks
1265   = hsep [ppr l, ptext SLIT("Interface file version error;"),
1266           ptext SLIT("Expected"), int opt_HiVersion,
1267           ptext SLIT("found "), pp_version]
1268     where
1269      pp_version =
1270       case hi_vers of
1271         Nothing -> ptext SLIT("pre ghc-3.02 version")
1272         Just v  -> ptext SLIT("version") <+> integer v
1273
1274 -----------------------------------------------------------------------------
1275
1276 srcParseErr :: StringBuffer -> SrcLoc -> Message
1277 srcParseErr s l
1278   = hcat [ppr l,
1279           if null token
1280              then ptext SLIT(": parse error (possibly incorrect indentation)")
1281              else hcat [ptext SLIT(": parse error on input "),
1282                         char '`', text token, char '\'']
1283     ]
1284   where
1285         token = lexemeToString s
1286
1287 \end{code}