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   | 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),
 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                         -- ignore RULES pragmas when -fglasgow-exts is off
 443                         Just ITrules_prag | not (flag glaexts) ->
 444                            skip_to_end (stepOnBy# buf 2#) s'
 445                         Just ITline_prag ->
 446                            line_prag skip_to_end buf2 s'
 447                         Just other -> is_a_token
 448                         Nothing -> skip_to_end (stepOnBy# buf 2#) s'
 449                   }}
 450
 451                 else skip_to_end (stepOnBy# buf 2#) s'
 452                 where
 453                     skip_to_end = skipNestedComment (lexer cont)
 454
 455                 -- special GHC extension: we grok cpp-style #line pragmas
 456             '#'# | lexemeIndex buf ==# bol ->   -- the '#' must be in column 0
 457                 case expandWhile# is_space (stepOn buf) of { buf1 ->
 458                 if is_digit (currentChar# buf1)
 459                         then line_prag next_line buf1 s'
 460                         else is_a_token
 461                 }
 462                 where
 463                 next_line buf = lexer cont (stepOnUntilChar# buf '\n'#)
 464
 465                 -- tabs have been expanded beforehand
 466             c | is_space c -> tab y bol atbol (stepOn buf)
 467               | otherwise  -> is_a_token
 468
 469            where s' = s{loc = replaceSrcLine loc y,
 470                         bol = bol,
 471                        atbol = atbol}
 472
 473                  is_a_token | atbol /=# 0# = lexBOL cont buf s'
 474                             | otherwise    = lexToken cont glaexts buf s'
 475
 476 -- {-# LINE .. #-} pragmas.  yeuch.
 477 line_prag cont buf s@PState{loc=loc} =
 478   case expandWhile# is_space buf                of { buf1 ->
 479   case scanNumLit 0 (stepOverLexeme buf1)       of { (line,buf2) ->
 480   -- subtract one: the line number refers to the *following* line.
 481   let real_line = line - 1 in
 482   case fromInteger real_line                    of { i@(I# l) ->
 483         -- ToDo, if no filename then we skip the newline.... d'oh
 484   case expandWhile# is_space buf2               of { buf3 ->
 485   case currentChar# buf3                        of
 486      '\"'#{-"-} ->
 487         case untilEndOfString# (stepOn (stepOverLexeme buf3)) of { buf4 ->
 488         let
 489             file = lexemeToFastString buf4
 490             new_buf = stepOn (stepOverLexeme buf4)
 491         in
 492         if nullFastString file
 493                 then cont new_buf s{loc = replaceSrcLine loc l}
 494                 else cont new_buf s{loc = mkSrcLoc file i}
 495         }
 496      _other -> cont (stepOverLexeme buf3) s{loc = replaceSrcLine loc l}
 497   }}}}
 498
 499 skipNestedComment :: P a -> P a
 500 skipNestedComment cont buf state = skipNestedComment' (loc state) cont buf state
 501
 502 skipNestedComment' :: SrcLoc -> P a -> P a
 503 skipNestedComment' orig_loc cont buf = loop buf
 504  where
 505    loop buf =
 506      case currentChar# buf of
 507         '-'# | lookAhead# buf 1# `eqChar#` '}'# -> cont (stepOnBy# buf 2#)
 508
 509         '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
 510               skipNestedComment
 511                 (skipNestedComment' orig_loc cont)
 512                 (stepOnBy# buf 2#)
 513
 514         '\n'# -> \ s@PState{loc=loc} ->
 515                  let buf' = stepOn buf in
 516                  loop buf' s{loc = incSrcLine loc,
 517                              bol = currentIndex# buf',
 518                              atbol = 1#}
 519
 520         -- pass the original SrcLoc to lexError so that the error is
 521         -- reported at the line it was originally on, not the line at
 522         -- the end of the file.
 523         '\NUL'# | bufferExhausted (stepOn buf) ->
 524                 \s -> lexError "unterminated `{-'" buf s{loc=orig_loc} -- -}
 525
 526         _   -> loop (stepOn buf)
 527
 528 -- When we are lexing the first token of a line, check whether we need to
 529 -- insert virtual semicolons or close braces due to layout.
 530
 531 lexBOL :: (Token -> P a) -> P a
 532 lexBOL cont buf s@(PState{
 533                     loc = loc,
 534                     glasgow_exts = glaexts,
 535                     bol = bol,
 536                     atbol = atbol,
 537                     context = ctx
 538                   }) =
 539         if need_close_curly then
 540                 --trace ("col = " ++ show (I# col) ++ ", layout: inserting '}'") $
 541                 cont ITvccurly buf s{atbol = 1#, context = tail ctx}
 542         else if need_semi_colon then
 543                 --trace ("col = " ++ show (I# col) ++ ", layout: inserting ';'") $
 544                 cont ITsemi buf s{atbol = 0#}
 545         else
 546                 lexToken cont glaexts buf s{atbol = 0#}
 547   where
 548         col = currentIndex# buf -# bol
 549
 550         need_close_curly =
 551                 case ctx of
 552                         [] -> False
 553                         (i:_) -> case i of
 554                                     NoLayout -> False
 555                                     Layout n -> col <# n
 556         need_semi_colon =
 557                 case ctx of
 558                         [] -> False
 559                         (i:_) -> case i of
 560                                     NoLayout -> False
 561                                     Layout n -> col ==# n
 562
 563
 564 lexToken :: (Token -> P a) -> Int# -> P a
 565 lexToken cont glaexts buf =
 566 -- trace "lexToken" $
 567   case currentChar# buf of
 568
 569     -- special symbols ----------------------------------------------------
 570     '('# | flag glaexts && lookAhead# buf 1# `eqChar#` '#'#
 571                 -> cont IToubxparen (setCurrentPos# buf 2#)
 572          | otherwise
 573                 -> cont IToparen (incLexeme buf)
 574
 575     ')'# -> cont ITcparen    (incLexeme buf)
 576     '['# -> cont ITobrack    (incLexeme buf)
 577     ']'# -> cont ITcbrack    (incLexeme buf)
 578     ','# -> cont ITcomma     (incLexeme buf)
 579     ';'# -> cont ITsemi      (incLexeme buf)
 580     '}'# -> \ s@PState{context = ctx} ->
 581             case ctx of
 582                 (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'}
 583                 _        -> lexError "too many '}'s" buf s
 584     '|'# -> case lookAhead# buf 1# of
 585                  '}'#  | flag glaexts -> cont ITccurlybar
 586                                               (setCurrentPos# buf 2#)
 587                  _                    -> lex_sym cont (incLexeme buf)
 588
 589
 590     '#'# -> case lookAhead# buf 1# of
 591                 ')'#  | flag glaexts -> cont ITcubxparen (setCurrentPos# buf 2#)
 592                 '-'# -> case lookAhead# buf 2# of
 593                            '}'# -> cont ITclose_prag (setCurrentPos# buf 3#)
 594                            _    -> lex_sym cont (incLexeme buf)
 595                 _    -> lex_sym cont (incLexeme buf)
 596
 597     '`'# | flag glaexts && lookAhead# buf 1# `eqChar#` '`'#
 598                 -> lex_cstring cont (setCurrentPos# buf 2#)
 599          | otherwise
 600                 -> cont ITbackquote (incLexeme buf)
 601
 602     '{'# ->     -- look for "{-##" special iface pragma
 603             case lookAhead# buf 1# of
 604            '|'# | flag glaexts
 605                 -> cont ITocurlybar (setCurrentPos# buf 2#)
 606            '-'# -> case lookAhead# buf 2# of
 607                     '#'# -> case lookAhead# buf 3# of
 608                                 '#'# ->
 609                                    lexPragma
 610                                       cont
 611                                       (\ cont lexeme buf' -> cont (ITpragma lexeme) buf')
 612                                       0#
 613                                       (stepOnBy# (stepOverLexeme buf) 4#)
 614                                 _ -> lex_prag cont (setCurrentPos# buf 3#)
 615                     _    -> cont ITocurly (incLexeme buf)
 616            _ -> (layoutOff `thenP_` cont ITocurly)  (incLexeme buf)
 617
 618     -- strings/characters -------------------------------------------------
 619     '\"'#{-"-} -> lex_string cont glaexts [] (incLexeme buf)
 620     '\''#      -> lex_char (char_end cont) glaexts (incLexeme buf)
 621
 622     -- strictness and cpr pragmas and __scc treated specially.
 623     '_'# | flag glaexts ->
 624          case lookAhead# buf 1# of
 625            '_'# -> case lookAhead# buf 2# of
 626                     'S'# ->
 627                         lex_demand cont (stepOnUntil (not . isSpace)
 628                                         (stepOnBy# buf 3#)) -- past __S
 629                     'M'# ->
 630                         cont ITcprinfo (stepOnBy# buf 3#)       -- past __M
 631
 632                     's'# ->
 633                         case prefixMatch (stepOnBy# buf 3#) "cc" of
 634                                Just buf' -> lex_scc cont (stepOverLexeme buf')
 635                                Nothing   -> lex_id cont glaexts buf
 636                     _ -> lex_id cont glaexts buf
 637            _    -> lex_id cont glaexts buf
 638
 639         -- Hexadecimal and octal constants
 640     '0'# | (ch `eqChar#` 'x'# || ch `eqChar#` 'X'#) && is_hexdigit ch2
 641                 -> readNum (after_lexnum cont glaexts) buf' is_hexdigit 16 hex
 642          | (ch `eqChar#` 'o'# || ch `eqChar#` 'O'#) && is_octdigit ch2
 643                 -> readNum (after_lexnum cont glaexts) buf' is_octdigit  8 oct_or_dec
 644         where ch   = lookAhead# buf 1#
 645               ch2  = lookAhead# buf 2#
 646               buf' = setCurrentPos# buf 2#
 647
 648     '\NUL'# ->
 649             if bufferExhausted (stepOn buf) then
 650                cont ITeof buf
 651             else
 652                trace "lexIface: misplaced NUL?" $
 653                cont (ITunknown "\NUL") (stepOn buf)
 654
 655     '?'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
 656             lex_ip cont (incLexeme buf)
 657     c | is_digit  c -> lex_num cont glaexts 0 buf
 658       | is_symbol c -> lex_sym cont buf
 659       | is_upper  c -> lex_con cont glaexts buf
 660       | is_ident  c -> lex_id  cont glaexts buf
 661       | otherwise   -> lexError "illegal character" buf
 662
 663 -- Int# is unlifted, and therefore faster than Bool for flags.
 664 {-# INLINE flag #-}
 665 flag :: Int# -> Bool
 666 flag 0# = False
 667 flag _  = True
 668
 669 -------------------------------------------------------------------------------
 670 -- Pragmas
 671
 672 lex_prag cont buf
 673   = case expandWhile# is_space buf of { buf1 ->
 674     case expandWhile# is_ident (stepOverLexeme buf1) of { buf2 ->
 675     let lexeme = mkFastString (map toUpper (lexemeToString buf2)) in
 676     case lookupUFM pragmaKeywordsFM lexeme of
 677         Just kw -> cont kw (mergeLexemes buf buf2)
 678         Nothing -> panic "lex_prag"
 679   }}
 680
 681 -------------------------------------------------------------------------------
 682 -- Strings & Chars
 683
 684 lex_string cont glaexts s buf
 685   = case currentChar# buf of
 686         '"'#{-"-} ->
 687            let buf' = incLexeme buf
 688                s' = mkFastStringNarrow (map chr (reverse s))
 689            in case currentChar# buf' of
 690                 '#'# | flag glaexts -> if all (<= 0xFF) s
 691                     then cont (ITprimstring s') (incLexeme buf')
 692                     else lexError "primitive string literal must contain only characters <= \'\\xFF\'" buf'
 693                 _                   -> cont (ITstring s') buf'
 694
 695         -- ignore \& in a string, deal with string gaps
 696         '\\'# | next_ch `eqChar#` '&'#
 697                 -> lex_string cont glaexts s buf'
 698               | is_space next_ch
 699                 -> lex_stringgap cont glaexts s (incLexeme buf)
 700
 701             where next_ch = lookAhead# buf 1#
 702                   buf' = setCurrentPos# buf 2#
 703
 704         _ -> lex_char (lex_next_string cont s) glaexts buf
 705
 706 lex_stringgap cont glaexts s buf
 707   = let buf' = incLexeme buf in
 708     case currentChar# buf of
 709         '\n'# -> \st@PState{loc = loc} -> lex_stringgap cont glaexts s buf'
 710                   st{loc = incSrcLine loc}
 711         '\\'# -> lex_string cont glaexts s buf'
 712         c | is_space c -> lex_stringgap cont glaexts s buf'
 713         other -> charError buf'
 714
 715 lex_next_string cont s glaexts c buf = lex_string cont glaexts (c:s) buf
 716
 717 lex_char :: (Int# -> Int -> P a) -> Int# -> P a
 718 lex_char cont glaexts buf
 719   = case currentChar# buf of
 720         '\\'# -> lex_escape (cont glaexts) (incLexeme buf)
 721         c | is_any c -> cont glaexts (I# (ord# c)) (incLexeme buf)
 722         other -> charError buf
 723
 724 char_end cont glaexts c buf
 725   = case currentChar# buf of
 726         '\''# -> let buf' = incLexeme buf in
 727                  case currentChar# buf' of
 728                         '#'# | flag glaexts
 729                                 -> cont (ITprimchar c) (incLexeme buf')
 730                         _       -> cont (ITchar c) buf'
 731         _     -> charError buf
 732
 733 lex_escape cont buf
 734   = let buf' = incLexeme buf in
 735     case currentChar# buf of
 736         'a'#       -> cont (ord '\a') buf'
 737         'b'#       -> cont (ord '\b') buf'
 738         'f'#       -> cont (ord '\f') buf'
 739         'n'#       -> cont (ord '\n') buf'
 740         'r'#       -> cont (ord '\r') buf'
 741         't'#       -> cont (ord '\t') buf'
 742         'v'#       -> cont (ord '\v') buf'
 743         '\\'#      -> cont (ord '\\') buf'
 744         '"'#       -> cont (ord '\"') buf'
 745         '\''#      -> cont (ord '\'') buf'
 746         '^'#       -> let c = currentChar# buf' in
 747                       if c `geChar#` '@'# && c `leChar#` '_'#
 748                         then cont (I# (ord# c -# ord# '@'#)) (incLexeme buf')
 749                         else charError buf'
 750
 751         'x'#      -> readNum (after_charnum cont) buf' is_hexdigit 16 hex
 752         'o'#      -> readNum (after_charnum cont) buf' is_octdigit  8 oct_or_dec
 753         x | is_digit x
 754                   -> readNum (after_charnum cont) buf is_digit    10 oct_or_dec
 755
 756         _          -> case [ (c,buf2) | (p,c) <- silly_escape_chars,
 757                                        Just buf2 <- [prefixMatch buf p] ] of
 758                             (c,buf2):_ -> cont (ord c) buf2
 759                             [] -> charError buf'
 760
 761 after_charnum cont i buf
 762   = if i >= 0 && i <= 0x10FFFF
 763         then cont (fromInteger i) buf
 764         else charError buf
 765
 766 readNum cont buf is_digit base conv = read buf 0
 767   where read buf i
 768           = case currentChar# buf of { c ->
 769             if is_digit c
 770                 then read (incLexeme buf) (i*base + (toInteger (I# (conv c))))
 771                 else cont i buf
 772             }
 773
 774 is_hexdigit c
 775         =  is_digit c
 776         || (c `geChar#` 'a'# && c `leChar#` 'f'#)
 777         || (c `geChar#` 'A'# && c `leChar#` 'F'#)
 778
 779 hex c | is_digit c = ord# c -# ord# '0'#
 780       | otherwise  = ord# (to_lower c) -# ord# 'a'# +# 10#
 781 oct_or_dec c = ord# c -# ord# '0'#
 782
 783 is_octdigit c = c `geChar#` '0'# && c `leChar#` '7'#
 784
 785 to_lower c
 786   | c `geChar#` 'A'# && c `leChar#` 'Z'#
 787         = chr# (ord# c -# (ord# 'A'# -# ord# 'a'#))
 788   | otherwise = c
 789
 790 charError buf = lexError "error in character literal" buf
 791
 792 silly_escape_chars = [
 793         ("NUL", '\NUL'),
 794         ("SOH", '\SOH'),
 795         ("STX", '\STX'),
 796         ("ETX", '\ETX'),
 797         ("EOT", '\EOT'),
 798         ("ENQ", '\ENQ'),
 799         ("ACK", '\ACK'),
 800         ("BEL", '\BEL'),
 801         ("BS", '\BS'),
 802         ("HT", '\HT'),
 803         ("LF", '\LF'),
 804         ("VT", '\VT'),
 805         ("FF", '\FF'),
 806         ("CR", '\CR'),
 807         ("SO", '\SO'),
 808         ("SI", '\SI'),
 809         ("DLE", '\DLE'),
 810         ("DC1", '\DC1'),
 811         ("DC2", '\DC2'),
 812         ("DC3", '\DC3'),
 813         ("DC4", '\DC4'),
 814         ("NAK", '\NAK'),
 815         ("SYN", '\SYN'),
 816         ("ETB", '\ETB'),
 817         ("CAN", '\CAN'),
 818         ("EM", '\EM'),
 819         ("SUB", '\SUB'),
 820         ("ESC", '\ESC'),
 821         ("FS", '\FS'),
 822         ("GS", '\GS'),
 823         ("RS", '\RS'),
 824         ("US", '\US'),
 825         ("SP", '\SP'),
 826         ("DEL", '\DEL')
 827         ]
 828
 829 -------------------------------------------------------------------------------
 830
 831 lex_demand cont buf =
 832  case read_em [] buf of { (ls,buf') ->
 833  case currentChar# buf' of
 834    'b'# -> cont (ITstrict (StrictSig (mkTopDmdType ls BotRes))) (incLexeme buf')
 835    'm'# -> cont (ITstrict (StrictSig (mkTopDmdType ls RetCPR))) (incLexeme buf')
 836    _    -> cont (ITstrict (StrictSig (mkTopDmdType ls TopRes))) buf'
 837  }
 838  where
 839   read_em acc buf =
 840    case currentChar# buf of
 841     'T'# -> read_em (Top     : acc) (stepOn buf)
 842     'L'# -> read_em (lazyDmd : acc) (stepOn buf)
 843     'A'# -> read_em (Abs     : acc) (stepOn buf)
 844     'V'# -> read_em (evalDmd : acc) (stepOn buf)        -- Temporary, until
 845                                                         -- we've recompiled prelude etc
 846     'C'# -> do_unary Call  acc (stepOnBy# buf 2#)       -- Skip 'C('
 847
 848     'U'# -> do_seq1 Eval         acc (stepOnBy# buf 1#)
 849     'D'# -> do_seq1 Defer        acc (stepOnBy# buf 1#)
 850     'S'# -> do_seq1 (Box . Eval) acc (stepOnBy# buf 1#)
 851
 852     _    -> (reverse acc, buf)
 853
 854   do_seq1 fn acc buf
 855     = case currentChar# buf of
 856         '('# -> do_seq2 fn acc (stepOnBy# buf 1#)
 857         _    -> read_em (fn (Poly Abs) : acc) buf
 858
 859   do_seq2 fn acc buf
 860     = case read_em [] buf of { (dmds, buf) ->
 861       case currentChar# buf of
 862         ')'# -> read_em (fn (Prod dmds) : acc)
 863                         (stepOn buf)
 864         '*'# -> ASSERT( length dmds == 1 )
 865                 read_em (fn (Poly (head dmds)) : acc)
 866                         (stepOnBy# buf 2#)      -- Skip '*)'
 867       }
 868
 869   do_unary fn acc buf
 870     = case read_em [] buf of
 871         ([dmd], rest) -> read_em (fn dmd : acc) (stepOn rest)   -- Skip ')'
 872
 873 ------------------
 874 lex_scc cont buf =
 875  case currentChar# buf of
 876   'C'# -> cont ITsccAllCafs (incLexeme buf)
 877   other -> cont ITscc buf
 878
 879 -----------------------------------------------------------------------------
 880 -- Numbers
 881
 882 lex_num :: (Token -> P a) -> Int# -> Integer -> P a
 883 lex_num cont glaexts acc buf =
 884  case scanNumLit acc buf of
 885      (acc',buf') ->
 886        case currentChar# buf' of
 887          '.'# | is_digit (lookAhead# buf' 1#) ->
 888              -- this case is not optimised at all, as the
 889              -- presence of floating point numbers in interface
 890              -- files is not that common. (ToDo)
 891             case expandWhile# is_digit (incLexeme buf') of
 892               buf2 -> -- points to first non digit char
 893
 894                 let l = case currentChar# buf2 of
 895                           'E'# -> do_exponent
 896                           'e'# -> do_exponent
 897                           _ -> buf2
 898
 899                     do_exponent
 900                         = let buf3 = incLexeme buf2 in
 901                           case currentChar# buf3 of
 902                                 '-'# -> expandWhile# is_digit (incLexeme buf3)
 903                                 '+'# -> expandWhile# is_digit (incLexeme buf3)
 904                                 x | is_digit x -> expandWhile# is_digit buf3
 905                                 _ -> buf2
 906
 907                     v = readRational__ (lexemeToString l)
 908
 909                 in case currentChar# l of -- glasgow exts only
 910                       '#'# | flag glaexts -> let l' = incLexeme l in
 911                               case currentChar# l' of
 912                                 '#'# -> cont (ITprimdouble v) (incLexeme l')
 913                                 _    -> cont (ITprimfloat  v) l'
 914                       _ -> cont (ITrational v) l
 915
 916          _ -> after_lexnum cont glaexts acc' buf'
 917
 918 after_lexnum cont glaexts i buf
 919   = case currentChar# buf of
 920         '#'# | flag glaexts -> cont (ITprimint i) (incLexeme buf)
 921         _    -> cont (ITinteger i) buf
 922
 923 -----------------------------------------------------------------------------
 924 -- C "literal literal"s  (i.e. things like ``NULL'', ``stdout'' etc.)
 925
 926 -- we lexemeToFastString on the bit between the ``''s, but include the
 927 -- quotes in the full lexeme.
 928
 929 lex_cstring cont buf =
 930  case expandUntilMatch (stepOverLexeme buf) "\'\'" of
 931    Just buf' -> cont (ITlitlit (lexemeToFastString
 932                                 (setCurrentPos# buf' (negateInt# 2#))))
 933                    (mergeLexemes buf buf')
 934    Nothing   -> lexError "unterminated ``" buf
 935
 936 -----------------------------------------------------------------------------
 937 -- identifiers, symbols etc.
 938
 939 lex_ip cont buf =
 940  case expandWhile# is_ident buf of
 941    buf' -> cont (ITipvarid lexeme) buf'
 942            where lexeme = lexemeToFastString buf'
 943
 944 lex_id cont glaexts buf =
 945  let buf1 = expandWhile# is_ident buf in
 946  seq buf1 $
 947
 948  case (if flag glaexts
 949         then expandWhile# (eqChar# '#'#) buf1 -- slurp trailing hashes
 950         else buf1)                              of { buf' ->
 951
 952  let lexeme  = lexemeToFastString buf' in
 953
 954  case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
 955         Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $
 956                           cont kwd_token buf';
 957         Nothing        ->
 958
 959  let var_token = cont (ITvarid lexeme) buf' in
 960
 961  if not (flag glaexts)
 962    then var_token
 963    else
 964
 965  case lookupUFM ghcExtensionKeywordsFM lexeme of {
 966         Just kwd_token -> cont kwd_token buf';
 967         Nothing        -> var_token
 968
 969  }}}
 970
 971 lex_sym cont buf =
 972  -- trace "lex_sym" $
 973  case expandWhile# is_symbol buf of
 974    buf' -> case lookupUFM haskellKeySymsFM lexeme of {
 975                 Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
 976                                   cont kwd_token buf' ;
 977                 Nothing        -> --trace ("sym: "++unpackFS lexeme) $
 978                                   cont (mk_var_token lexeme) buf'
 979            }
 980         where lexeme = lexemeToFastString buf'
 981
 982
 983 -- lex_con recursively collects components of a qualified identifer.
 984 -- The argument buf is the StringBuffer representing the lexeme
 985 -- identified so far, where the next character is upper-case.
 986
 987 lex_con cont glaexts buf =
 988  -- trace ("con: "{-++unpackFS lexeme-}) $
 989  let empty_buf = stepOverLexeme buf in
 990  case expandWhile# is_ident empty_buf    of { buf1 ->
 991  case slurp_trailing_hashes buf1 glaexts of { con_buf ->
 992
 993  let all_buf = mergeLexemes buf con_buf
 994
 995      con_lexeme = lexemeToFastString con_buf
 996      mod_lexeme = lexemeToFastString (decLexeme buf)
 997      all_lexeme = lexemeToFastString all_buf
 998
 999      just_a_conid
1000         | emptyLexeme buf = cont (ITconid con_lexeme)               all_buf
1001         | otherwise       = cont (ITqconid (mod_lexeme,con_lexeme)) all_buf
1002  in
1003
1004  case currentChar# all_buf of
1005      '.'# -> maybe_qualified cont glaexts all_lexeme
1006                 (incLexeme all_buf) just_a_conid
1007      _    -> just_a_conid
1008   }}
1009
1010
1011 maybe_qualified cont glaexts mod buf just_a_conid =
1012  -- trace ("qid: "{-++unpackFS lexeme-}) $
1013  case currentChar# buf of
1014   '['# ->       -- Special case for []
1015     case lookAhead# buf 1# of
1016      ']'# -> cont (ITqconid  (mod,SLIT("[]"))) (setCurrentPos# buf 2#)
1017      _    -> just_a_conid
1018
1019   '('# ->  -- Special case for (,,,)
1020            -- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)"
1021     case lookAhead# buf 1# of
1022      '#'# | flag glaexts -> case lookAhead# buf 2# of
1023                 ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#)
1024                                 just_a_conid
1025                 _    -> just_a_conid
1026      ')'# -> cont (ITqconid (mod,SLIT("()"))) (setCurrentPos# buf 2#)
1027      ','# -> lex_tuple cont mod (setCurrentPos# buf 2#) just_a_conid
1028      _    -> just_a_conid
1029
1030   '-'# -> case lookAhead# buf 1# of
1031             '>'# -> cont (ITqconid (mod,SLIT("(->)"))) (setCurrentPos# buf 2#)
1032             _    -> lex_id3 cont glaexts mod buf just_a_conid
1033
1034   _    -> lex_id3 cont glaexts mod buf just_a_conid
1035
1036
1037 lex_id3 cont glaexts mod buf just_a_conid
1038   | is_upper (currentChar# buf) =
1039      lex_con cont glaexts buf
1040
1041   | is_symbol (currentChar# buf) =
1042      let
1043         start_new_lexeme = stepOverLexeme buf
1044      in
1045      -- trace ("lex_id31 "{-++unpackFS lexeme-}) $
1046      case expandWhile# is_symbol start_new_lexeme of { buf' ->
1047      let
1048        lexeme  = lexemeToFastString buf'
1049         -- real lexeme is M.<sym>
1050        new_buf = mergeLexemes buf buf'
1051      in
1052      cont (mk_qvar_token mod lexeme) new_buf
1053         -- wrong, but arguably morally right: M... is now a qvarsym
1054      }
1055
1056   | otherwise   =
1057      let
1058         start_new_lexeme = stepOverLexeme buf
1059      in
1060      -- trace ("lex_id32 "{-++unpackFS lexeme-}) $
1061      case expandWhile# is_ident start_new_lexeme of { buf1 ->
1062      if emptyLexeme buf1
1063             then just_a_conid
1064             else
1065
1066      case slurp_trailing_hashes buf1 glaexts of { buf' ->
1067
1068      let
1069       lexeme      = lexemeToFastString buf'
1070       new_buf     = mergeLexemes buf buf'
1071       is_a_qvarid = cont (mk_qvar_token mod lexeme) new_buf
1072      in
1073      case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
1074             Nothing          -> is_a_qvarid ;
1075
1076             Just kwd_token | isSpecial kwd_token   -- special ids (as, qualified, hiding) shouldn't be
1077                            -> is_a_qvarid          --  recognised as keywords here.
1078                            | otherwise
1079                            -> just_a_conid         -- avoid M.where etc.
1080      }}}
1081
1082 slurp_trailing_hashes buf glaexts
1083   | flag glaexts = expandWhile# (`eqChar#` '#'#) buf
1084   | otherwise    = buf
1085
1086
1087 mk_var_token pk_str
1088   | is_upper f          = ITconid pk_str
1089   | is_ident f          = ITvarid pk_str
1090   | f `eqChar#` ':'#    = ITconsym pk_str
1091   | otherwise           = ITvarsym pk_str
1092   where
1093       (C# f) = _HEAD_ pk_str
1094       -- tl     = _TAIL_ pk_str
1095
1096 mk_qvar_token m token =
1097 -- trace ("mk_qvar ") $
1098  case mk_var_token token of
1099    ITconid n  -> ITqconid  (m,n)
1100    ITvarid n  -> ITqvarid  (m,n)
1101    ITconsym n -> ITqconsym (m,n)
1102    ITvarsym n -> ITqvarsym (m,n)
1103    _          -> ITunknown (show token)
1104 \end{code}
1105
1106 ----------------------------------------------------------------------------
1107 Horrible stuff for dealing with M.(,,,)
1108
1109 \begin{code}
1110 lex_tuple cont mod buf back_off =
1111   go 2 buf
1112   where
1113    go n buf =
1114     case currentChar# buf of
1115       ','# -> go (n+1) (stepOn buf)
1116       ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Boxed n))) (stepOn buf)
1117       _    -> back_off
1118
1119 lex_ubx_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       '#'# -> case lookAhead# buf 1# of
1126                 ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Unboxed n)))
1127                                  (stepOnBy# buf 2#)
1128                 _    -> back_off
1129       _    -> back_off
1130 \end{code}
1131
1132 -----------------------------------------------------------------------------
1133 'lexPragma' rips along really fast, looking for a '##-}',
1134 indicating the end of the pragma we're skipping
1135
1136 \begin{code}
1137 lexPragma cont contf inStr buf =
1138  case currentChar# buf of
1139    '#'# | inStr ==# 0# ->
1140        case lookAhead# buf 1# of { '#'# ->
1141        case lookAhead# buf 2# of { '-'# ->
1142        case lookAhead# buf 3# of { '}'# ->
1143            contf cont (lexemeToBuffer buf)
1144                       (stepOverLexeme (setCurrentPos# buf 4#));
1145         _    -> lexPragma cont contf inStr (incLexeme buf) };
1146         _    -> lexPragma cont contf inStr (incLexeme buf) };
1147         _    -> lexPragma cont contf inStr (incLexeme buf) }
1148
1149    '"'# ->
1150        let
1151         odd_slashes buf flg i# =
1152           case lookAhead# buf i# of
1153            '\\'# -> odd_slashes buf (not flg) (i# -# 1#)
1154            _     -> flg
1155
1156         not_inStr = if inStr ==# 0# then 1# else 0#
1157        in
1158        case lookAhead# buf (negateInt# 1#) of --backwards, actually
1159          '\\'# -> -- escaping something..
1160            if odd_slashes buf True (negateInt# 2#)
1161                 then  -- odd number of slashes, " is escaped.
1162                       lexPragma cont contf inStr (incLexeme buf)
1163                 else  -- even number of slashes, \ is escaped.
1164                       lexPragma cont contf not_inStr (incLexeme buf)
1165          _ -> lexPragma cont contf not_inStr (incLexeme buf)
1166
1167    '\''# | inStr ==# 0# ->
1168         case lookAhead# buf 1# of { '"'# ->
1169         case lookAhead# buf 2# of { '\''# ->
1170            lexPragma cont contf inStr (setCurrentPos# buf 3#);
1171         _ -> lexPragma cont contf inStr (incLexeme buf) };
1172         _ -> lexPragma cont contf inStr (incLexeme buf) }
1173
1174     -- a sign that the input is ill-formed, since pragmas are
1175     -- assumed to always be properly closed (in .hi files).
1176    '\NUL'# -> trace "lexPragma: unexpected end-of-file" $
1177               cont (ITunknown "\NUL") buf
1178
1179    _ -> lexPragma cont contf inStr (incLexeme buf)
1180
1181 \end{code}
1182
1183 -----------------------------------------------------------------------------
1184
1185 \begin{code}
1186 data LayoutContext
1187   = NoLayout
1188   | Layout Int#
1189
1190 data ParseResult a
1191   = POk PState a
1192   | PFailed Message
1193
1194 data PState = PState {
1195         loc           :: SrcLoc,
1196         glasgow_exts  :: Int#,
1197         bol           :: Int#,
1198         atbol         :: Int#,
1199         context       :: [LayoutContext]
1200      }
1201
1202 type P a = StringBuffer         -- Input string
1203         -> PState
1204         -> ParseResult a
1205
1206 returnP   :: a -> P a
1207 returnP a buf s = POk s a
1208
1209 thenP      :: P a -> (a -> P b) -> P b
1210 m `thenP` k = \ buf s ->
1211         case m buf s of
1212                 POk s1 a -> k a buf s1
1213                 PFailed err  -> PFailed err
1214
1215 thenP_     :: P a -> P b -> P b
1216 m `thenP_` k = m `thenP` \_ -> k
1217
1218 mapP :: (a -> P b) -> [a] -> P [b]
1219 mapP f [] = returnP []
1220 mapP f (a:as) =
1221      f a `thenP` \b ->
1222      mapP f as `thenP` \bs ->
1223      returnP (b:bs)
1224
1225 failP :: String -> P a
1226 failP msg buf s = PFailed (text msg)
1227
1228 failMsgP :: Message -> P a
1229 failMsgP msg buf s = PFailed msg
1230
1231 lexError :: String -> P a
1232 lexError str buf s@PState{ loc = loc }
1233   = failMsgP (hcat [ppr loc, text ": ", text str]) buf s
1234
1235 getSrcLocP :: P SrcLoc
1236 getSrcLocP buf s@(PState{ loc = loc }) = POk s loc
1237
1238 -- use a temporary SrcLoc for the duration of the argument
1239 setSrcLocP :: SrcLoc -> P a -> P a
1240 setSrcLocP new_loc p buf s =
1241   case p buf s{ loc=new_loc } of
1242       POk _ a   -> POk s a
1243       PFailed e -> PFailed e
1244
1245 getSrcFile :: P FAST_STRING
1246 getSrcFile buf s@(PState{ loc = loc }) = POk s (srcLocFile loc)
1247
1248 pushContext :: LayoutContext -> P ()
1249 pushContext ctxt buf s@(PState{ context = ctx }) = POk s{context = ctxt:ctx} ()
1250
1251 {-
1252
1253 This special case in layoutOn is to handle layout contexts with are
1254 indented the same or less than the current context.  This is illegal
1255 according to the Haskell spec, so we have to arrange to close the
1256 current context.  eg.
1257
1258 class Foo a where
1259 class Bar a
1260
1261 after the first 'where', the sequence of events is:
1262
1263         - layout system inserts a ';' (column 0)
1264         - parser begins a new context at column 0
1265         - parser shifts ';' (legal empty declaration)
1266         - parser sees 'class': parse error (we're still in the inner context)
1267
1268 trouble is, by the time we know we need a new context, the lexer has
1269 already generated the ';'.  Hacky solution is as follows: since we
1270 know the column of the next token (it's the column number of the new
1271 context), we set the ACTUAL column number of the new context to this
1272 numer plus one.  Hence the next time the lexer is called, a '}' will
1273 be generated to close the new context straight away.  Furthermore, we
1274 have to set the atbol flag so that the ';' that the parser shifted as
1275 part of the new context is re-generated.
1276
1277 when the new context is *less* indented than the current one:
1278
1279 f = f where g = g where
1280 h = h
1281
1282         - current context: column 12.
1283         - on seeing 'h' (column 0), the layout system inserts '}'
1284         - parser starts a new context, column 0
1285         - parser sees '}', uses it to close new context
1286         - we still need to insert another '}' followed by a ';',
1287           hence the atbol trick.
1288
1289 There's also a special hack in here to deal with
1290
1291         do
1292            ....
1293            e $ do
1294            blah
1295
1296 i.e. the inner context is at the same indentation level as the outer
1297 context.  This is strictly illegal according to Haskell 98, but
1298 there's a lot of existing code using this style and it doesn't make
1299 any sense to disallow it, since empty 'do' lists don't make sense.
1300 -}
1301
1302 layoutOn :: Bool -> P ()
1303 layoutOn strict buf s@(PState{ bol = bol, context = ctx }) =
1304     let offset = lexemeIndex buf -# bol in
1305     case ctx of
1306         Layout prev_off : _
1307            | if strict then prev_off >=# offset else prev_off ># offset ->
1308                 --trace ("layout on, column: " ++  show (I# offset)) $
1309                 POk s{ context = Layout (offset +# 1#) : ctx, atbol = 1# } ()
1310         other ->
1311                 --trace ("layout on, column: " ++  show (I# offset)) $
1312                 POk s{ context = Layout offset : ctx } ()
1313
1314 layoutOff :: P ()
1315 layoutOff buf s@(PState{ context = ctx }) =
1316     POk s{ context = NoLayout:ctx } ()
1317
1318 popContext :: P ()
1319 popContext = \ buf s@(PState{ context = ctx, loc = loc }) ->
1320   case ctx of
1321         (_:tl) -> POk s{ context = tl } ()
1322         []     -> PFailed (srcParseErr buf loc)
1323
1324 {-
1325  Note that if the name of the file we're processing ends
1326  with `hi-boot', we accept it on faith as having the right
1327  version. This is done so that .hi-boot files that comes
1328  with hsc don't have to be updated before every release,
1329  *and* it allows us to share .hi-boot files with versions
1330  of hsc that don't have .hi version checking (e.g., ghc-2.10's)
1331
1332  If the version number is 0, the checking is also turned off.
1333  (needed to deal with GHC.hi only!)
1334
1335  Once we can assume we're compiling with a version of ghc that
1336  supports interface file checking, we can drop the special
1337  pleading
1338 -}
1339 checkVersion :: Maybe Integer -> P ()
1340 checkVersion mb@(Just v) buf s@(PState{loc = loc})
1341  | (v==0) || (v == fromInt opt_HiVersion) || opt_NoHiCheck = POk s ()
1342  | otherwise = PFailed (ifaceVersionErr mb loc ([]::[Token]){-Todo-})
1343 checkVersion mb@Nothing  buf s@(PState{loc = loc})
1344  | "hi-boot" `isSuffixOf` (_UNPK_ (srcLocFile loc)) = POk s ()
1345  | otherwise = PFailed (ifaceVersionErr mb loc ([]::[Token]){-Todo-})
1346
1347 -----------------------------------------------------------------
1348
1349 ifaceParseErr :: StringBuffer -> SrcLoc -> Message
1350 ifaceParseErr s l
1351   = hsep [ppr l, ptext SLIT("Interface file parse error; on input `"),
1352           text (lexemeToString s), char '\'']
1353
1354 ifaceVersionErr hi_vers l toks
1355   = hsep [ppr l, ptext SLIT("Interface file version error;"),
1356           ptext SLIT("Expected"), int opt_HiVersion,
1357           ptext SLIT("found "), pp_version]
1358     where
1359      pp_version =
1360       case hi_vers of
1361         Nothing -> ptext SLIT("pre ghc-3.02 version")
1362         Just v  -> ptext SLIT("version") <+> integer v
1363
1364 -----------------------------------------------------------------------------
1365
1366 srcParseErr :: StringBuffer -> SrcLoc -> Message
1367 srcParseErr s l
1368   = hcat [ppr l,
1369           if null token
1370              then ptext SLIT(": parse error (possibly incorrect indentation)")
1371              else hcat [ptext SLIT(": parse error on input "),
1372                         char '`', text token, char '\'']
1373     ]
1374   where
1375         token = lexemeToString s
1376
1377 \end{code}