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