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