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