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