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       ( 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 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 True  acc (stepOnBy# buf 2#)
 835     'u'# -> do_unpack False acc (stepOnBy# buf 2#)
 836     _    -> (reverse acc, buf)
 837
 838   do_unpack wrapper_unpacks acc buf
 839    = case read_em [] buf of
 840       (stuff, rest) -> read_em (WwUnpack wrapper_unpacks stuff : acc) rest
 841
 842
 843 ------------------
 844 lex_scc cont buf =
 845  case currentChar# buf of
 846   'C'# -> cont ITsccAllCafs (incLexeme buf)
 847   other -> cont ITscc buf
 848
 849 -----------------------------------------------------------------------------
 850 -- Numbers
 851
 852 lex_num :: (Token -> P a) -> Int# -> Integer -> P a
 853 lex_num cont glaexts acc buf =
 854  case scanNumLit acc buf of
 855      (acc',buf') ->
 856        case currentChar# buf' of
 857          '.'# | is_digit (lookAhead# buf' 1#) ->
 858              -- this case is not optimised at all, as the
 859              -- presence of floating point numbers in interface
 860              -- files is not that common. (ToDo)
 861             case expandWhile# is_digit (incLexeme buf') of
 862               buf2 -> -- points to first non digit char
 863
 864                 let l = case currentChar# buf2 of
 865                           'E'# -> do_exponent
 866                           'e'# -> do_exponent
 867                           _ -> buf2
 868
 869                     do_exponent
 870                         = let buf3 = incLexeme buf2 in
 871                           case currentChar# buf3 of
 872                                 '-'# -> expandWhile# is_digit (incLexeme buf3)
 873                                 '+'# -> expandWhile# is_digit (incLexeme buf3)
 874                                 x | is_digit x -> expandWhile# is_digit buf3
 875                                 _ -> buf2
 876
 877                     v = readRational__ (lexemeToString l)
 878
 879                 in case currentChar# l of -- glasgow exts only
 880                       '#'# | flag glaexts -> let l' = incLexeme l in
 881                               case currentChar# l' of
 882                                 '#'# -> cont (ITprimdouble v) (incLexeme l')
 883                                 _    -> cont (ITprimfloat  v) l'
 884                       _ -> cont (ITrational v) l
 885
 886          _ -> after_lexnum cont glaexts acc' buf'
 887
 888 after_lexnum cont glaexts i buf
 889   = case currentChar# buf of
 890         '#'# | flag glaexts -> cont (ITprimint i) (incLexeme buf)
 891         _    -> cont (ITinteger i) buf
 892
 893 -----------------------------------------------------------------------------
 894 -- C "literal literal"s  (i.e. things like ``NULL'', ``stdout'' etc.)
 895
 896 -- we lexemeToFastString on the bit between the ``''s, but include the
 897 -- quotes in the full lexeme.
 898
 899 lex_cstring cont buf =
 900  case expandUntilMatch (stepOverLexeme buf) "\'\'" of
 901    Just buf' -> cont (ITlitlit (lexemeToFastString
 902                                 (setCurrentPos# buf' (negateInt# 2#))))
 903                    (mergeLexemes buf buf')
 904    Nothing   -> lexError "unterminated ``" buf
 905
 906 -----------------------------------------------------------------------------
 907 -- identifiers, symbols etc.
 908
 909 lex_ip cont buf =
 910  case expandWhile# is_ident buf of
 911    buf' -> cont (ITipvarid lexeme) buf'
 912            where lexeme = lexemeToFastString buf'
 913
 914 lex_id cont glaexts buf =
 915  let buf1 = expandWhile# is_ident buf in
 916  seq buf1 $
 917
 918  case (if flag glaexts
 919         then expandWhile# (eqChar# '#'#) buf1 -- slurp trailing hashes
 920         else buf1)                              of { buf' ->
 921
 922  let lexeme  = lexemeToFastString buf' in
 923
 924  case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
 925         Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $
 926                           cont kwd_token buf';
 927         Nothing        ->
 928
 929  let var_token = cont (ITvarid lexeme) buf' in
 930
 931  if not (flag glaexts)
 932    then var_token
 933    else
 934
 935  case lookupUFM ghcExtensionKeywordsFM lexeme of {
 936         Just kwd_token -> cont kwd_token buf';
 937         Nothing        -> var_token
 938
 939  }}}
 940
 941 lex_sym cont buf =
 942  -- trace "lex_sym" $
 943  case expandWhile# is_symbol buf of
 944    buf' -> case lookupUFM haskellKeySymsFM lexeme of {
 945                 Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
 946                                   cont kwd_token buf' ;
 947                 Nothing        -> --trace ("sym: "++unpackFS lexeme) $
 948                                   cont (mk_var_token lexeme) buf'
 949            }
 950         where lexeme = lexemeToFastString buf'
 951
 952
 953 -- lex_con recursively collects components of a qualified identifer.
 954 -- The argument modbuf is the StringBuffer representing the lexeme
 955 -- identified so far.  The buf argument is an empty StringBuffer pointing
 956 -- to the next character to be examined.
 957
 958 lex_con cont glaexts modbuf buf =
 959  -- trace ("con: "{-++unpackFS lexeme-}) $
 960  case expandWhile# is_ident buf          of { buf1 ->
 961  case slurp_trailing_hashes buf1 glaexts of { buf' ->
 962
 963  case currentChar# buf' of
 964      '.'# -> maybe_qualified cont glaexts modbuf' mod_lexeme
 965                 (incLexeme buf') just_a_conid
 966      _    -> just_a_conid
 967   where
 968     mod_lexeme = lexemeToFastString modbuf'
 969     modbuf'    = mergeLexemes modbuf buf'
 970
 971     just_a_conid
 972         | emptyLexeme modbuf = cont (ITconid mod_lexeme) buf'
 973         | otherwise          = cont (ITqconid (lexemeToFastString modbuf,
 974                                                lexemeToFastString buf')) buf'
 975   }}
 976
 977
 978 maybe_qualified cont glaexts modbuf mod buf just_a_conid =
 979  -- trace ("qid: "{-++unpackFS lexeme-}) $
 980  case currentChar# buf of
 981   '['# ->       -- Special case for []
 982     case lookAhead# buf 1# of
 983      ']'# -> cont (ITqconid  (mod,SLIT("[]"))) (setCurrentPos# buf 2#)
 984      _    -> just_a_conid
 985
 986   '('# ->  -- Special case for (,,,)
 987            -- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)"
 988     case lookAhead# buf 1# of
 989      '#'# | flag glaexts -> case lookAhead# buf 2# of
 990                 ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#)
 991                                 just_a_conid
 992                 _    -> just_a_conid
 993      ')'# -> cont (ITqconid (mod,SLIT("()"))) (setCurrentPos# buf 2#)
 994      ','# -> lex_tuple cont mod (setCurrentPos# buf 2#) just_a_conid
 995      _    -> just_a_conid
 996
 997   '-'# -> case lookAhead# buf 1# of
 998             '>'# -> cont (ITqconid (mod,SLIT("(->)"))) (setCurrentPos# buf 2#)
 999             _    -> lex_id3 cont glaexts modbuf mod buf just_a_conid
1000
1001   _    -> lex_id3 cont glaexts modbuf mod buf just_a_conid
1002
1003
1004 lex_id3 cont glaexts modbuf mod buf just_a_conid
1005   | is_upper (currentChar# buf) =
1006      lex_con cont glaexts modbuf (stepOverLexeme buf)
1007
1008   | is_symbol (currentChar# buf) =
1009      let
1010         start_new_lexeme = stepOverLexeme buf
1011      in
1012      -- trace ("lex_id31 "{-++unpackFS lexeme-}) $
1013      case expandWhile# is_symbol start_new_lexeme of { buf' ->
1014      let
1015        lexeme  = lexemeToFastString buf'
1016         -- real lexeme is M.<sym>
1017        new_buf = mergeLexemes buf buf'
1018      in
1019      cont (mk_qvar_token mod lexeme) new_buf
1020         -- wrong, but arguably morally right: M... is now a qvarsym
1021      }
1022
1023   | otherwise   =
1024      let
1025         start_new_lexeme = stepOverLexeme buf
1026      in
1027      -- trace ("lex_id32 "{-++unpackFS lexeme-}) $
1028      case expandWhile# is_ident start_new_lexeme of { buf1 ->
1029      if emptyLexeme buf1
1030             then just_a_conid
1031             else
1032
1033      case slurp_trailing_hashes buf1 glaexts of { buf' ->
1034
1035      let
1036       lexeme      = lexemeToFastString buf'
1037       new_buf     = mergeLexemes buf buf'
1038       is_a_qvarid = cont (mk_qvar_token mod lexeme) new_buf
1039      in
1040      case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
1041             Nothing          -> is_a_qvarid ;
1042
1043             Just kwd_token | isSpecial kwd_token   -- special ids (as, qualified, hiding) shouldn't be
1044                            -> is_a_qvarid          --  recognised as keywords here.
1045                            | otherwise
1046                            -> just_a_conid         -- avoid M.where etc.
1047      }}}
1048
1049 slurp_trailing_hashes buf glaexts
1050   | flag glaexts = expandWhile# (`eqChar#` '#'#) buf
1051   | otherwise    = buf
1052
1053
1054 mk_var_token pk_str
1055   | is_upper f          = ITconid pk_str
1056   | is_ident f          = ITvarid pk_str
1057   | f `eqChar#` ':'#    = ITconsym pk_str
1058   | otherwise           = ITvarsym pk_str
1059   where
1060       (C# f) = _HEAD_ pk_str
1061       -- tl     = _TAIL_ pk_str
1062
1063 mk_qvar_token m token =
1064 -- trace ("mk_qvar ") $
1065  case mk_var_token token of
1066    ITconid n  -> ITqconid  (m,n)
1067    ITvarid n  -> ITqvarid  (m,n)
1068    ITconsym n -> ITqconsym (m,n)
1069    ITvarsym n -> ITqvarsym (m,n)
1070    _          -> ITunknown (show token)
1071 \end{code}
1072
1073 ----------------------------------------------------------------------------
1074 Horrible stuff for dealing with M.(,,,)
1075
1076 \begin{code}
1077 lex_tuple cont mod buf back_off =
1078   go 2 buf
1079   where
1080    go n buf =
1081     case currentChar# buf of
1082       ','# -> go (n+1) (stepOn buf)
1083       ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Boxed n))) (stepOn buf)
1084       _    -> back_off
1085
1086 lex_ubx_tuple cont mod buf back_off =
1087   go 2 buf
1088   where
1089    go n buf =
1090     case currentChar# buf of
1091       ','# -> go (n+1) (stepOn buf)
1092       '#'# -> case lookAhead# buf 1# of
1093                 ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Unboxed n)))
1094                                  (stepOnBy# buf 2#)
1095                 _    -> back_off
1096       _    -> back_off
1097 \end{code}
1098
1099 -----------------------------------------------------------------------------
1100 doDiscard rips along really fast, looking for a '##-}',
1101 indicating the end of the pragma we're skipping
1102
1103 \begin{code}
1104 doDiscard inStr buf =
1105  case currentChar# buf of
1106    '#'# | inStr ==# 0# ->
1107        case lookAhead# buf 1# of { '#'# ->
1108        case lookAhead# buf 2# of { '-'# ->
1109        case lookAhead# buf 3# of { '}'# ->
1110            (lexemeToBuffer buf, stepOverLexeme (setCurrentPos# buf 4#));
1111         _    -> doDiscard inStr (incLexeme buf) };
1112         _    -> doDiscard inStr (incLexeme buf) };
1113         _    -> doDiscard inStr (incLexeme buf) }
1114
1115    '"'# ->
1116        let
1117         odd_slashes buf flg i# =
1118           case lookAhead# buf i# of
1119            '\\'# -> odd_slashes buf (not flg) (i# -# 1#)
1120            _     -> flg
1121
1122         not_inStr = if inStr ==# 0# then 1# else 0#
1123        in
1124        case lookAhead# buf (negateInt# 1#) of --backwards, actually
1125          '\\'# -> -- escaping something..
1126            if odd_slashes buf True (negateInt# 2#)
1127                 then  -- odd number of slashes, " is escaped.
1128                       doDiscard inStr (incLexeme buf)
1129                 else  -- even number of slashes, \ is escaped.
1130                       doDiscard not_inStr (incLexeme buf)
1131          _ -> doDiscard not_inStr (incLexeme buf)
1132
1133    '\''# | inStr ==# 0# ->
1134         case lookAhead# buf 1# of { '"'# ->
1135         case lookAhead# buf 2# of { '\''# ->
1136            doDiscard inStr (setCurrentPos# buf 3#);
1137         _ -> doDiscard inStr (incLexeme buf) };
1138         _ -> doDiscard inStr (incLexeme buf) }
1139
1140    _ -> doDiscard inStr (incLexeme buf)
1141
1142 \end{code}
1143
1144 -----------------------------------------------------------------------------
1145
1146 \begin{code}
1147 data LayoutContext
1148   = NoLayout
1149   | Layout Int#
1150
1151 data ParseResult a
1152   = POk PState a
1153   | PFailed Message
1154
1155 data PState = PState {
1156         loc           :: SrcLoc,
1157         glasgow_exts  :: Int#,
1158         bol           :: Int#,
1159         atbol         :: Int#,
1160         context       :: [LayoutContext]
1161      }
1162
1163 type P a = StringBuffer         -- Input string
1164         -> PState
1165         -> ParseResult a
1166
1167 returnP   :: a -> P a
1168 returnP a buf s = POk s a
1169
1170 thenP      :: P a -> (a -> P b) -> P b
1171 m `thenP` k = \ buf s ->
1172         case m buf s of
1173                 POk s1 a -> k a buf s1
1174                 PFailed err  -> PFailed err
1175
1176 thenP_     :: P a -> P b -> P b
1177 m `thenP_` k = m `thenP` \_ -> k
1178
1179 mapP :: (a -> P b) -> [a] -> P [b]
1180 mapP f [] = returnP []
1181 mapP f (a:as) =
1182      f a `thenP` \b ->
1183      mapP f as `thenP` \bs ->
1184      returnP (b:bs)
1185
1186 failP :: String -> P a
1187 failP msg buf s = PFailed (text msg)
1188
1189 failMsgP :: Message -> P a
1190 failMsgP msg buf s = PFailed msg
1191
1192 lexError :: String -> P a
1193 lexError str buf s@PState{ loc = loc }
1194   = failMsgP (hcat [ppr loc, text ": ", text str]) buf s
1195
1196 getSrcLocP :: P SrcLoc
1197 getSrcLocP buf s@(PState{ loc = loc }) = POk s loc
1198
1199 -- use a temporary SrcLoc for the duration of the argument
1200 setSrcLocP :: SrcLoc -> P a -> P a
1201 setSrcLocP new_loc p buf s =
1202   case p buf s{ loc=new_loc } of
1203       POk _ a   -> POk s a
1204       PFailed e -> PFailed e
1205
1206 getSrcFile :: P FAST_STRING
1207 getSrcFile buf s@(PState{ loc = loc }) = POk s (srcLocFile loc)
1208
1209 pushContext :: LayoutContext -> P ()
1210 pushContext ctxt buf s@(PState{ context = ctx }) = POk s{context = ctxt:ctx} ()
1211
1212 {-
1213
1214 This special case in layoutOn is to handle layout contexts with are
1215 indented the same or less than the current context.  This is illegal
1216 according to the Haskell spec, so we have to arrange to close the
1217 current context.  eg.
1218
1219 class Foo a where
1220 class Bar a
1221
1222 after the first 'where', the sequence of events is:
1223
1224         - layout system inserts a ';' (column 0)
1225         - parser begins a new context at column 0
1226         - parser shifts ';' (legal empty declaration)
1227         - parser sees 'class': parse error (we're still in the inner context)
1228
1229 trouble is, by the time we know we need a new context, the lexer has
1230 already generated the ';'.  Hacky solution is as follows: since we
1231 know the column of the next token (it's the column number of the new
1232 context), we set the ACTUAL column number of the new context to this
1233 numer plus one.  Hence the next time the lexer is called, a '}' will
1234 be generated to close the new context straight away.  Furthermore, we
1235 have to set the atbol flag so that the ';' that the parser shifted as
1236 part of the new context is re-generated.
1237
1238 when the new context is *less* indented than the current one:
1239
1240 f = f where g = g where
1241 h = h
1242
1243         - current context: column 12.
1244         - on seeing 'h' (column 0), the layout system inserts '}'
1245         - parser starts a new context, column 0
1246         - parser sees '}', uses it to close new context
1247         - we still need to insert another '}' followed by a ';',
1248           hence the atbol trick.
1249
1250 There's also a special hack in here to deal with
1251
1252         do
1253            ....
1254            e $ do
1255            blah
1256
1257 i.e. the inner context is at the same indentation level as the outer
1258 context.  This is strictly illegal according to Haskell 98, but
1259 there's a lot of existing code using this style and it doesn't make
1260 any sense to disallow it, since empty 'do' lists don't make sense.
1261 -}
1262
1263 layoutOn :: Bool -> P ()
1264 layoutOn strict buf s@(PState{ bol = bol, context = ctx }) =
1265     let offset = lexemeIndex buf -# bol in
1266     case ctx of
1267         Layout prev_off : _
1268            | if strict then prev_off >=# offset else prev_off ># offset ->
1269                 --trace ("layout on, column: " ++  show (I# offset)) $
1270                 POk s{ context = Layout (offset +# 1#) : ctx, atbol = 1# } ()
1271         other ->
1272                 --trace ("layout on, column: " ++  show (I# offset)) $
1273                 POk s{ context = Layout offset : ctx } ()
1274
1275 layoutOff :: P ()
1276 layoutOff buf s@(PState{ context = ctx }) =
1277     POk s{ context = NoLayout:ctx } ()
1278
1279 popContext :: P ()
1280 popContext = \ buf s@(PState{ context = ctx, loc = loc }) ->
1281   case ctx of
1282         (_:tl) -> POk s{ context = tl } ()
1283         []     -> PFailed (srcParseErr buf loc)
1284
1285 {-
1286  Note that if the name of the file we're processing ends
1287  with `hi-boot', we accept it on faith as having the right
1288  version. This is done so that .hi-boot files that comes
1289  with hsc don't have to be updated before every release,
1290  *and* it allows us to share .hi-boot files with versions
1291  of hsc that don't have .hi version checking (e.g., ghc-2.10's)
1292
1293  If the version number is 0, the checking is also turned off.
1294  (needed to deal with GHC.hi only!)
1295
1296  Once we can assume we're compiling with a version of ghc that
1297  supports interface file checking, we can drop the special
1298  pleading
1299 -}
1300 checkVersion :: Maybe Integer -> P ()
1301 checkVersion mb@(Just v) buf s@(PState{loc = loc})
1302  | (v==0) || (v == fromInt opt_HiVersion) || opt_NoHiCheck = POk s ()
1303  | otherwise = PFailed (ifaceVersionErr mb loc ([]::[Token]){-Todo-})
1304 checkVersion mb@Nothing  buf s@(PState{loc = loc})
1305  | "hi-boot" `isSuffixOf` (_UNPK_ (srcLocFile loc)) = POk s ()
1306  | otherwise = PFailed (ifaceVersionErr mb loc ([]::[Token]){-Todo-})
1307
1308 -----------------------------------------------------------------
1309
1310 ifaceParseErr :: StringBuffer -> SrcLoc -> Message
1311 ifaceParseErr s l
1312   = hsep [ppr l, ptext SLIT("Interface file parse error; on input `"),
1313           text (lexemeToString s), char '\'']
1314
1315 ifaceVersionErr hi_vers l toks
1316   = hsep [ppr l, ptext SLIT("Interface file version error;"),
1317           ptext SLIT("Expected"), int opt_HiVersion,
1318           ptext SLIT("found "), pp_version]
1319     where
1320      pp_version =
1321       case hi_vers of
1322         Nothing -> ptext SLIT("pre ghc-3.02 version")
1323         Just v  -> ptext SLIT("version") <+> integer v
1324
1325 -----------------------------------------------------------------------------
1326
1327 srcParseErr :: StringBuffer -> SrcLoc -> Message
1328 srcParseErr s l
1329   = hcat [ppr l,
1330           if null token
1331              then ptext SLIT(": parse error (possibly incorrect indentation)")
1332              else hcat [ptext SLIT(": parse error on input "),
1333                         char '`', text token, char '\'']
1334     ]
1335   where
1336         token = lexemeToString s
1337
1338 \end{code}