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