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