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