ghc/compiler/parser/Lexer.x

   1 -----------------------------------------------------------------------------
   2 -- (c) The University of Glasgow, 2003
   3 --
   4 -- GHC's lexer.
   5 --
   6 -- This is a combination of an Alex-generated lexer from a regex
   7 -- definition, with some hand-coded bits.
   8 --
   9 -- Completely accurate information about token-spans within the source
  10 -- file is maintained.  Every token has a start and end SrcLoc attached to it.
  11 --
  12 -----------------------------------------------------------------------------
  13
  14 --   ToDo / known bugs:
  15 --    - Unicode
  16 --    - parsing integers is a bit slow
  17 --    - readRational is a bit slow
  18 --
  19 --   Known bugs, that were also in the previous version:
  20 --    - M... should be 3 tokens, not 1.
  21 --    - pragma-end should be only valid in a pragma
  22
  23 {
  24 module Lexer (
  25    Token(..), Token__(..), lexer, mkPState, showPFailed,
  26    P(..), ParseResult(..), setSrcLocFor, getSrcLoc,
  27    failMsgP, failLocMsgP, srcParseFail,
  28    popContext, pushCurrentContext,
  29   ) where
  30
  31 #include "HsVersions.h"
  32
  33 import ForeignCall      ( Safety(..) )
  34 import ErrUtils         ( Message )
  35 import Outputable
  36 import StringBuffer
  37 import FastString
  38 import FastTypes
  39 import SrcLoc
  40 import UniqFM
  41 import CmdLineOpts
  42 import Ctype
  43 import Util             ( maybePrefixMatch )
  44
  45 import DATA_BITS
  46 import Char
  47 import Ratio
  48 import TRACE
  49 }
  50
  51 $whitechar   = [\ \t\n\r\f\v]
  52 $white_no_nl = $whitechar # \n
  53
  54 $ascdigit  = 0-9
  55 $unidigit  = \x01
  56 $digit     = [$ascdigit $unidigit]
  57
  58 $special   = [\(\)\,\;\[\]\`\{\}]
  59 $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
  60 $unisymbol = \x02
  61 $symbol    = [$ascsymbol $unisymbol] # [$special \_\:\"\']
  62
  63 $unilarge  = \x03
  64 $asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]
  65 $large     = [$asclarge $unilarge]
  66
  67 $unismall  = \x04
  68 $ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]
  69 $small     = [$ascsmall $unismall \_]
  70
  71 $graphic   = [$small $large $symbol $digit $special \:\"\']
  72
  73 $octit     = 0-7
  74 $hexit     = [$digit A-F a-f]
  75 $symchar   = [$symbol \:]
  76 $nl        = [\n\r]
  77 $idchar    = [$small $large $digit \']
  78
  79 @varid     = $small $idchar*
  80 @conid     = $large $idchar*
  81
  82 @varsym    = $symbol $symchar*
  83 @consym    = \: $symchar*
  84
  85 @decimal     = $digit+
  86 @octal       = $octit+
  87 @hexadecimal = $hexit+
  88 @exponent    = [eE] [\-\+]? @decimal
  89
  90 -- we support the hierarchical module name extension:
  91 @qual = (@conid \.)+
  92
  93 @floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
  94
  95 haskell :-
  96
  97 -- everywhere: skip whitespace and comments
  98 $white_no_nl+                           ;
  99
 100 -- Everywhere: deal with nested comments.  We explicitly rule out
 101 -- pragmas, "{-#", so that we don't accidentally treat them as comments.
 102 -- (this can happen even though pragmas will normally take precedence due to
 103 -- longest-match, because pragmas aren't valid in every state, but comments
 104 -- are).
 105 "{-" / { notFollowedBy '#' }            { nested_comment }
 106
 107 -- Single-line comments are a bit tricky.  Haskell 98 says that two or
 108 -- more dashes followed by a symbol should be parsed as a varsym, so we
 109 -- have to exclude those.
 110 -- The regex says: "munch all the characters after the dashes, as long as
 111 -- the first one is not a symbol".
 112 "--"\-* ([^$symbol] .*)?                ;
 113
 114 -- 'bol' state: beginning of a line.  Slurp up all the whitespace (including
 115 -- blank lines) until we find a non-whitespace character, then do layout
 116 -- processing.
 117 --
 118 -- One slight wibble here: what if the line begins with {-#? In
 119 -- theory, we have to lex the pragma to see if it's one we recognise,
 120 -- and if it is, then we backtrack and do_bol, otherwise we treat it
 121 -- as a nested comment.  We don't bother with this: if the line begins
 122 -- with {-#, then we'll assume it's a pragma we know about and go for do_bol.
 123 <bol> {
 124   \n                                    ;
 125   ^\# (line)?                           { begin line_prag1 }
 126   ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently
 127   ()                                    { do_bol }
 128 }
 129
 130 -- after a layout keyword (let, where, do, of), we begin a new layout
 131 -- context if the curly brace is missing.
 132 -- Careful! This stuff is quite delicate.
 133 <layout, layout_do> {
 134   \{ / { notFollowedBy '-' }            { pop_and open_brace }
 135         -- we might encounter {-# here, but {- has been handled already
 136   \n                                    ;
 137   ^\# (line)?                           { begin line_prag1 }
 138 }
 139
 140 -- do is treated in a subtly different way, see new_layout_context
 141 <layout>    ()                          { new_layout_context True }
 142 <layout_do> ()                          { new_layout_context False }
 143
 144 -- after a new layout context which was found to be to the left of the
 145 -- previous context, we have generated a '{' token, and we now need to
 146 -- generate a matching '}' token.
 147 <layout_left>  ()                       { do_layout_left }
 148
 149 <0,glaexts> \n                          { begin bol }
 150
 151 "{-#" $whitechar* (line|LINE)           { begin line_prag2 }
 152
 153 -- single-line line pragmas, of the form
 154 --    # <line> "<file>" <extra-stuff> \n
 155 <line_prag1> $digit+                    { set_line line_prag1a }
 156 <line_prag1a> \" [$graphic \ ]* \"      { set_file line_prag1b }
 157 <line_prag1b> .*                        { pop }
 158
 159 -- Haskell-style line pragmas, of the form
 160 --    {-# LINE <line> "<file>" #-}
 161 <line_prag2> $digit+                    { set_line line_prag2a }
 162 <line_prag2a> \" [$graphic \ ]* \"      { set_file line_prag2b }
 163 <line_prag2b> "#-}"                     { pop }
 164
 165 <0,glaexts> {
 166   "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
 167                                         { token ITspecialise_prag }
 168   "{-#" $whitechar* (SOURCE|source)     { token ITsource_prag }
 169   "{-#" $whitechar* (INLINE|inline)     { token ITinline_prag }
 170   "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline)
 171                                         { token ITnoinline_prag }
 172   "{-#" $whitechar* (RULES|rules)       { token ITrules_prag }
 173   "{-#" $whitechar* (DEPRECATED|deprecated)
 174                                         { token ITdeprecated_prag }
 175   "{-#" $whitechar* (SCC|scc)           { token ITscc_prag }
 176   "{-#" $whitechar* (CORE|core)         { token ITcore_prag }
 177
 178   "{-#"                                 { nested_comment }
 179
 180   -- ToDo: should only be valid inside a pragma:
 181   "#-}"                                 { token ITclose_prag}
 182 }
 183
 184
 185 -- '0' state: ordinary lexemes
 186 -- 'glaexts' state: glasgow extensions (postfix '#', etc.)
 187
 188 -- "special" symbols
 189
 190 <0,glaexts> {
 191   "[:" / { ifExtension parrEnabled }    { token ITopabrack }
 192   ":]" / { ifExtension parrEnabled }    { token ITcpabrack }
 193 }
 194
 195 <0,glaexts> {
 196   "[|"      / { ifExtension thEnabled } { token ITopenExpQuote }
 197   "[e|"     / { ifExtension thEnabled } { token ITopenExpQuote }
 198   "[p|"     / { ifExtension thEnabled } { token ITopenPatQuote }
 199   "[d|"     / { ifExtension thEnabled } { layout_token ITopenDecQuote }
 200   "[t|"     / { ifExtension thEnabled } { token ITopenTypQuote }
 201   "|]"      / { ifExtension thEnabled } { token ITcloseQuote }
 202   \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
 203   "$("      / { ifExtension thEnabled } { token ITparenEscape }
 204 }
 205
 206 <0,glaexts> {
 207   "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
 208                                         { special IToparenbar }
 209   "|)" / { ifExtension arrowsEnabled }  { special ITcparenbar }
 210 }
 211
 212 <0,glaexts> {
 213   \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
 214   \% @varid / { ifExtension ipEnabled } { skip_one_varid ITsplitipvarid }
 215 }
 216
 217 <glaexts> {
 218   "(#" / { notFollowedBySymbol }        { token IToubxparen }
 219   "#)"                                  { token ITcubxparen }
 220   "{|"                                  { token ITocurlybar }
 221   "|}"                                  { token ITccurlybar }
 222 }
 223
 224 <0,glaexts> {
 225   \(                                    { special IToparen }
 226   \)                                    { special ITcparen }
 227   \[                                    { special ITobrack }
 228   \]                                    { special ITcbrack }
 229   \,                                    { special ITcomma }
 230   \;                                    { special ITsemi }
 231   \`                                    { special ITbackquote }
 232
 233   \{                                    { open_brace }
 234   \}                                    { close_brace }
 235 }
 236
 237 <0,glaexts> {
 238   @qual @varid                  { check_qvarid }
 239   @qual @conid                  { idtoken qconid }
 240   @varid                        { varid }
 241   @conid                        { idtoken conid }
 242 }
 243
 244 -- after an illegal qvarid, such as 'M.let',
 245 -- we back up and try again in the bad_qvarid state:
 246 <bad_qvarid> {
 247   @conid                        { pop_and (idtoken conid) }
 248   @qual @conid                  { pop_and (idtoken qconid) }
 249 }
 250
 251 <glaexts> {
 252   @qual @varid "#"+             { idtoken qvarid }
 253   @qual @conid "#"+             { idtoken qconid }
 254   @varid "#"+                   { varid }
 255   @conid "#"+                   { idtoken conid }
 256 }
 257
 258 -- ToDo: M.(,,,)
 259
 260 <0,glaexts> {
 261   @qual @varsym                 { idtoken qvarsym }
 262   @qual @consym                 { idtoken qconsym }
 263   @varsym                       { varsym }
 264   @consym                       { consym }
 265 }
 266
 267 <0,glaexts> {
 268   @decimal                      { tok_decimal }
 269   0[oO] @octal                  { tok_octal }
 270   0[xX] @hexadecimal            { tok_hexadecimal }
 271 }
 272
 273 <glaexts> {
 274   @decimal \#                   { prim_decimal }
 275   0[oO] @octal \#               { prim_octal }
 276   0[xX] @hexadecimal \#         { prim_hexadecimal }
 277 }
 278
 279 <0,glaexts> @floating_point             { strtoken tok_float }
 280 <glaexts>   @floating_point \#          { init_strtoken 1 prim_float }
 281 <glaexts>   @floating_point \# \#       { init_strtoken 2 prim_double }
 282
 283 -- Strings and chars are lexed by hand-written code.  The reason is
 284 -- that even if we recognise the string or char here in the regex
 285 -- lexer, we would still have to parse the string afterward in order
 286 -- to convert it to a String.
 287 <0,glaexts> {
 288   \'                            { lex_char_tok }
 289   \"                            { lex_string_tok }
 290 }
 291
 292 {
 293 -- work around bug in Alex 2.0
 294 #if __GLASGOW_HASKELL__ < 503
 295 unsafeAt arr i = arr ! i
 296 #endif
 297
 298 -- -----------------------------------------------------------------------------
 299 -- The token type
 300
 301 data Token = T SrcLoc{-start-} SrcLoc{-end-} Token__
 302
 303 data Token__
 304   = ITas                        -- Haskell keywords
 305   | ITcase
 306   | ITclass
 307   | ITdata
 308   | ITdefault
 309   | ITderiving
 310   | ITdo
 311   | ITelse
 312   | IThiding
 313   | ITif
 314   | ITimport
 315   | ITin
 316   | ITinfix
 317   | ITinfixl
 318   | ITinfixr
 319   | ITinstance
 320   | ITlet
 321   | ITmodule
 322   | ITnewtype
 323   | ITof
 324   | ITqualified
 325   | ITthen
 326   | ITtype
 327   | ITwhere
 328   | ITscc                       -- ToDo: remove (we use {-# SCC "..." #-} now)
 329
 330   | ITforall                    -- GHC extension keywords
 331   | ITforeign
 332   | ITexport
 333   | ITlabel
 334   | ITdynamic
 335   | ITsafe
 336   | ITthreadsafe
 337   | ITunsafe
 338   | ITstdcallconv
 339   | ITccallconv
 340   | ITdotnet
 341   | ITmdo
 342
 343   | ITspecialise_prag           -- Pragmas
 344   | ITsource_prag
 345   | ITinline_prag
 346   | ITnoinline_prag
 347   | ITrules_prag
 348   | ITdeprecated_prag
 349   | ITline_prag
 350   | ITscc_prag
 351   | ITcore_prag                 -- hdaume: core annotations
 352   | ITclose_prag
 353
 354   | ITdotdot                    -- reserved symbols
 355   | ITcolon
 356   | ITdcolon
 357   | ITequal
 358   | ITlam
 359   | ITvbar
 360   | ITlarrow
 361   | ITrarrow
 362   | ITat
 363   | ITtilde
 364   | ITdarrow
 365   | ITminus
 366   | ITbang
 367   | ITstar
 368   | ITdot
 369
 370   | ITbiglam                    -- GHC-extension symbols
 371
 372   | ITocurly                    -- special symbols
 373   | ITccurly
 374   | ITocurlybar                 -- {|, for type applications
 375   | ITccurlybar                 -- |}, for type applications
 376   | ITvocurly
 377   | ITvccurly
 378   | ITobrack
 379   | ITopabrack                  -- [:, for parallel arrays with -fparr
 380   | ITcpabrack                  -- :], for parallel arrays with -fparr
 381   | ITcbrack
 382   | IToparen
 383   | ITcparen
 384   | IToubxparen
 385   | ITcubxparen
 386   | ITsemi
 387   | ITcomma
 388   | ITunderscore
 389   | ITbackquote
 390
 391   | ITvarid   FastString        -- identifiers
 392   | ITconid   FastString
 393   | ITvarsym  FastString
 394   | ITconsym  FastString
 395   | ITqvarid  (FastString,FastString)
 396   | ITqconid  (FastString,FastString)
 397   | ITqvarsym (FastString,FastString)
 398   | ITqconsym (FastString,FastString)
 399
 400   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
 401   | ITsplitipvarid FastString   -- GHC extension: implicit param: %x
 402
 403   | ITpragma StringBuffer
 404
 405   | ITchar       Char
 406   | ITstring     FastString
 407   | ITinteger    Integer
 408   | ITrational   Rational
 409
 410   | ITprimchar   Char
 411   | ITprimstring FastString
 412   | ITprimint    Integer
 413   | ITprimfloat  Rational
 414   | ITprimdouble Rational
 415
 416   -- MetaHaskell extension tokens
 417   | ITopenExpQuote              -- [| or [e|
 418   | ITopenPatQuote              -- [p|
 419   | ITopenDecQuote              -- [d|
 420   | ITopenTypQuote              -- [t|
 421   | ITcloseQuote                -- |]
 422   | ITidEscape   FastString     -- $x
 423   | ITparenEscape               -- $(
 424   | ITvarQuote                  -- '
 425   | ITtyQuote                   -- ''
 426
 427   -- Arrow notation extension
 428   | ITproc
 429   | ITrec
 430   | IToparenbar                 -- (|
 431   | ITcparenbar                 -- |)
 432   | ITlarrowtail                -- -<
 433   | ITrarrowtail                -- >-
 434   | ITLarrowtail                -- -<<
 435   | ITRarrowtail                -- >>-
 436
 437   | ITunknown String            -- Used when the lexer can't make sense of it
 438   | ITeof                       -- end of file token
 439 #ifdef DEBUG
 440   deriving Show -- debugging
 441 #endif
 442
 443 isSpecial :: Token__ -> Bool
 444 -- If we see M.x, where x is a keyword, but
 445 -- is special, we treat is as just plain M.x,
 446 -- not as a keyword.
 447 isSpecial ITas          = True
 448 isSpecial IThiding      = True
 449 isSpecial ITqualified   = True
 450 isSpecial ITforall      = True
 451 isSpecial ITexport      = True
 452 isSpecial ITlabel       = True
 453 isSpecial ITdynamic     = True
 454 isSpecial ITsafe        = True
 455 isSpecial ITthreadsafe  = True
 456 isSpecial ITunsafe      = True
 457 isSpecial ITccallconv   = True
 458 isSpecial ITstdcallconv = True
 459 isSpecial ITmdo         = True
 460 isSpecial _             = False
 461
 462 -- the bitmap provided as the third component indicates whether the
 463 -- corresponding extension keyword is valid under the extension options
 464 -- provided to the compiler; if the extension corresponding to *any* of the
 465 -- bits set in the bitmap is enabled, the keyword is valid (this setup
 466 -- facilitates using a keyword in two different extensions that can be
 467 -- activated independently)
 468 --
 469 reservedWordsFM = listToUFM $
 470         map (\(x, y, z) -> (mkFastString x, (y, z)))
 471        [( "_",          ITunderscore,   0 ),
 472         ( "as",         ITas,           0 ),
 473         ( "case",       ITcase,         0 ),
 474         ( "class",      ITclass,        0 ),
 475         ( "data",       ITdata,         0 ),
 476         ( "default",    ITdefault,      0 ),
 477         ( "deriving",   ITderiving,     0 ),
 478         ( "do",         ITdo,           0 ),
 479         ( "else",       ITelse,         0 ),
 480         ( "hiding",     IThiding,       0 ),
 481         ( "if",         ITif,           0 ),
 482         ( "import",     ITimport,       0 ),
 483         ( "in",         ITin,           0 ),
 484         ( "infix",      ITinfix,        0 ),
 485         ( "infixl",     ITinfixl,       0 ),
 486         ( "infixr",     ITinfixr,       0 ),
 487         ( "instance",   ITinstance,     0 ),
 488         ( "let",        ITlet,          0 ),
 489         ( "module",     ITmodule,       0 ),
 490         ( "newtype",    ITnewtype,      0 ),
 491         ( "of",         ITof,           0 ),
 492         ( "qualified",  ITqualified,    0 ),
 493         ( "then",       ITthen,         0 ),
 494         ( "type",       ITtype,         0 ),
 495         ( "where",      ITwhere,        0 ),
 496         ( "_scc_",      ITscc,          0 ),            -- ToDo: remove
 497
 498         ( "forall",     ITforall,        bit glaExtsBit),
 499         ( "mdo",        ITmdo,           bit glaExtsBit),
 500
 501         ( "foreign",    ITforeign,       bit ffiBit),
 502         ( "export",     ITexport,        bit ffiBit),
 503         ( "label",      ITlabel,         bit ffiBit),
 504         ( "dynamic",    ITdynamic,       bit ffiBit),
 505         ( "safe",       ITsafe,          bit ffiBit),
 506         ( "threadsafe", ITthreadsafe,    bit ffiBit),
 507         ( "unsafe",     ITunsafe,        bit ffiBit),
 508         ( "stdcall",    ITstdcallconv,   bit ffiBit),
 509         ( "ccall",      ITccallconv,     bit ffiBit),
 510         ( "dotnet",     ITdotnet,        bit ffiBit),
 511
 512         ( "rec",        ITrec,           bit arrowsBit),
 513         ( "proc",       ITproc,          bit arrowsBit)
 514      ]
 515
 516 reservedSymsFM = listToUFM $
 517         map (\ (x,y,z) -> (mkFastString x,(y,z)))
 518       [ ("..",  ITdotdot,       0)
 519        ,(":",   ITcolon,        0)      -- (:) is a reserved op,
 520                                                 -- meaning only list cons
 521        ,("::",  ITdcolon,       0)
 522        ,("=",   ITequal,        0)
 523        ,("\\",  ITlam,          0)
 524        ,("|",   ITvbar,         0)
 525        ,("<-",  ITlarrow,       0)
 526        ,("->",  ITrarrow,       0)
 527        ,("@",   ITat,           0)
 528        ,("~",   ITtilde,        0)
 529        ,("=>",  ITdarrow,       0)
 530        ,("-",   ITminus,        0)
 531        ,("!",   ITbang,         0)
 532
 533        ,("*",   ITstar,         bit glaExtsBit) -- For data T (a::*) = MkT
 534        ,(".",   ITdot,          bit glaExtsBit) -- For 'forall a . t'
 535
 536        ,("-<",  ITlarrowtail,   bit arrowsBit)
 537        ,(">-",  ITrarrowtail,   bit arrowsBit)
 538        ,("-<<", ITLarrowtail,   bit arrowsBit)
 539        ,(">>-", ITRarrowtail,   bit arrowsBit)
 540        ]
 541
 542 -- -----------------------------------------------------------------------------
 543 -- Lexer actions
 544
 545 type Action = SrcLoc -> SrcLoc -> StringBuffer -> Int -> P Token
 546
 547 special :: Token__ -> Action
 548 special tok loc end _buf len = return (T loc end tok)
 549
 550 token, layout_token :: Token__ -> Action
 551 token t loc end buf len = return (T loc end t)
 552 layout_token t loc end buf len = pushLexState layout >> return (T loc end t)
 553
 554 idtoken :: (StringBuffer -> Int -> Token__) -> Action
 555 idtoken f loc end buf len = return (T loc end $! (f buf len))
 556
 557 skip_one_varid :: (FastString -> Token__) -> Action
 558 skip_one_varid f loc end buf len
 559   = return (T loc end $! f (lexemeToFastString (stepOn buf) (len-1)))
 560
 561 strtoken :: (String -> Token__) -> Action
 562 strtoken f loc end buf len =
 563   return (T loc end $! (f $! lexemeToString buf len))
 564
 565 init_strtoken :: Int -> (String -> Token__) -> Action
 566 -- like strtoken, but drops the last N character(s)
 567 init_strtoken drop f loc end buf len =
 568   return (T loc end $! (f $! lexemeToString buf (len-drop)))
 569
 570 begin :: Int -> Action
 571 begin code _loc _end _str _len = do pushLexState code; lexToken
 572
 573 pop :: Action
 574 pop _loc _end _buf _len = do popLexState; lexToken
 575
 576 pop_and :: Action -> Action
 577 pop_and act loc end buf len = do popLexState; act loc end buf len
 578
 579 notFollowedBy char _ _ _ (_,buf) = atEnd buf || currentChar buf /= char
 580
 581 notFollowedBySymbol _ _ _ (_,buf)
 582   = atEnd buf || currentChar buf `notElem` "!#$%&*+./<=>?@\\^|-~"
 583
 584 ifExtension pred bits _ _ _ = pred bits
 585
 586 {-
 587   nested comments require traversing by hand, they can't be parsed
 588   using regular expressions.
 589 -}
 590 nested_comment :: Action
 591 nested_comment loc _end _str _len = do
 592   input <- getInput
 593   go 1 input
 594   where go 0 input = do setInput input; lexToken
 595         go n input = do
 596           case alexGetChar input of
 597             Nothing  -> err input
 598             Just (c,input) -> do
 599               case c of
 600                 '-' -> do
 601                   case alexGetChar input of
 602                     Nothing  -> err input
 603                     Just ('\125',input) -> go (n-1) input
 604                     Just (c,_)          -> go n input
 605                 '\123' -> do
 606                   case alexGetChar input of
 607                     Nothing  -> err input
 608                     Just ('-',input') -> go (n+1) input'
 609                     Just (c,input)    -> go n input
 610                 c -> go n input
 611
 612         err input = do failLocMsgP loc (fst input) "unterminated `{-'"
 613
 614 open_brace, close_brace :: Action
 615 open_brace  loc end _str _len = do
 616   ctx <- getContext
 617   setContext (NoLayout:ctx)
 618   return (T loc end ITocurly)
 619 close_brace loc end _str _len = do
 620   popContext
 621   return (T loc end ITccurly)
 622
 623 -- We have to be careful not to count M.<varid> as a qualified name
 624 -- when <varid> is a keyword.  We hack around this by catching
 625 -- the offending tokens afterward, and re-lexing in a different state.
 626 check_qvarid loc end buf len = do
 627   case lookupUFM reservedWordsFM var of
 628         Just (keyword,exts)
 629           | not (isSpecial keyword) ->
 630           if exts == 0
 631              then try_again
 632              else do
 633                 b <- extension (\i -> exts .&. i /= 0)
 634                 if b then try_again
 635                      else return token
 636         _other -> return token
 637   where
 638         (mod,var) = splitQualName buf len
 639         token     = T loc end (ITqvarid (mod,var))
 640
 641         try_again = do
 642                 setInput (loc,buf)
 643                 pushLexState bad_qvarid
 644                 lexToken
 645
 646 qvarid buf len = ITqvarid $! splitQualName buf len
 647 qconid buf len = ITqconid $! splitQualName buf len
 648
 649 splitQualName :: StringBuffer -> Int -> (FastString,FastString)
 650 -- takes a StringBuffer and a length, and returns the module name
 651 -- and identifier parts of a qualified name.  Splits at the *last* dot,
 652 -- because of hierarchical module names.
 653 splitQualName orig_buf len = split orig_buf 0 0
 654   where
 655     split buf dot_off n
 656         | n == len                = done dot_off
 657         | lookAhead buf n == '.'  = split2 buf n (n+1)
 658         | otherwise               = split buf dot_off (n+1)
 659
 660     -- careful, we might get names like M....
 661     -- so, if the character after the dot is not upper-case, this is
 662     -- the end of the qualifier part.
 663     split2 buf dot_off n
 664         | isUpper (lookAhead buf n) = split buf dot_off (n+1)
 665         | otherwise                 = done dot_off
 666
 667     done dot_off =
 668         (lexemeToFastString orig_buf dot_off,
 669          lexemeToFastString (stepOnBy (dot_off+1) orig_buf) (len - dot_off -1))
 670
 671 varid loc end buf len =
 672   case lookupUFM reservedWordsFM fs of
 673         Just (keyword,0)    -> do
 674                 maybe_layout keyword
 675                 return (T loc end keyword)
 676         Just (keyword,exts) -> do
 677                 b <- extension (\i -> exts .&. i /= 0)
 678                 if b then do maybe_layout keyword
 679                              return (T loc end keyword)
 680                      else return (T loc end (ITvarid fs))
 681         _other -> return (T loc end (ITvarid fs))
 682   where
 683         fs = lexemeToFastString buf len
 684
 685 conid buf len = ITconid fs
 686   where fs = lexemeToFastString buf len
 687
 688 qvarsym buf len = ITqvarsym $! splitQualName buf len
 689 qconsym buf len = ITqconsym $! splitQualName buf len
 690
 691 varsym = sym ITvarsym
 692 consym = sym ITconsym
 693
 694 sym con loc end buf len =
 695   case lookupUFM reservedSymsFM fs of
 696         Just (keyword,0)    -> return (T loc end keyword)
 697         Just (keyword,exts) -> do
 698                 b <- extension (\i -> exts .&. i /= 0)
 699                 if b then return (T loc end keyword)
 700                      else return (T loc end $! con fs)
 701         _other -> return (T loc end $! con fs)
 702   where
 703         fs = lexemeToFastString buf len
 704
 705 tok_decimal loc end buf len
 706   = return (T loc end (ITinteger  $! parseInteger buf len 10 oct_or_dec))
 707
 708 tok_octal loc end buf len
 709   = return (T loc end (ITinteger  $! parseInteger (stepOnBy 2 buf) (len-2) 8 oct_or_dec))
 710
 711 tok_hexadecimal loc end buf len
 712   = return (T loc end (ITinteger  $! parseInteger (stepOnBy 2 buf) (len-2) 16 hex))
 713
 714 prim_decimal loc end buf len
 715   = return (T loc end (ITprimint  $! parseInteger buf (len-1) 10 oct_or_dec))
 716
 717 prim_octal loc end buf len
 718   = return (T loc end (ITprimint  $! parseInteger (stepOnBy 2 buf) (len-3) 8 oct_or_dec))
 719
 720 prim_hexadecimal loc end buf len
 721   = return (T loc end (ITprimint  $! parseInteger (stepOnBy 2 buf) (len-3) 16 hex))
 722
 723 tok_float        str = ITrational $! readRational__ str
 724 prim_float       str = ITprimfloat  $! readRational__ str
 725 prim_double      str = ITprimdouble $! readRational__ str
 726
 727 parseInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer
 728 parseInteger buf len radix to_int
 729   = go 0 0
 730   where go i x | i == len  = x
 731                | otherwise = go (i+1) (x * radix + toInteger (to_int (lookAhead buf i)))
 732
 733 -- -----------------------------------------------------------------------------
 734 -- Layout processing
 735
 736 -- we're at the first token on a line, insert layout tokens if necessary
 737 do_bol :: Action
 738 do_bol loc end _str _len = do
 739         pos <- getOffside end
 740         case pos of
 741             LT -> do
 742                 --trace "layout: inserting '}'" $ do
 743                 popContext
 744                 -- do NOT pop the lex state, we might have a ';' to insert
 745                 return (T loc end ITvccurly)
 746             EQ -> do
 747                 --trace "layout: inserting ';'" $ do
 748                 popLexState
 749                 return (T loc end ITsemi)
 750             GT -> do
 751                 popLexState
 752                 lexToken
 753
 754 -- certain keywords put us in the "layout" state, where we might
 755 -- add an opening curly brace.
 756 maybe_layout ITdo       = pushLexState layout_do
 757 maybe_layout ITmdo      = pushLexState layout_do
 758 maybe_layout ITof       = pushLexState layout
 759 maybe_layout ITlet      = pushLexState layout
 760 maybe_layout ITwhere    = pushLexState layout
 761 maybe_layout ITrec      = pushLexState layout
 762 maybe_layout _          = return ()
 763
 764 -- Pushing a new implicit layout context.  If the indentation of the
 765 -- next token is not greater than the previous layout context, then
 766 -- Haskell 98 says that the new layout context should be empty; that is
 767 -- the lexer must generate {}.
 768 --
 769 -- We are slightly more lenient than this: when the new context is started
 770 -- by a 'do', then we allow the new context to be at the same indentation as
 771 -- the previous context.  This is what the 'strict' argument is for.
 772 --
 773 new_layout_context strict loc end _buf _len = do
 774     popLexState
 775     let offset = srcLocCol loc
 776     ctx <- getContext
 777     case ctx of
 778         Layout prev_off : _  |
 779            (strict     && prev_off >= offset  ||
 780             not strict && prev_off > offset) -> do
 781                 -- token is indented to the left of the previous context.
 782                 -- we must generate a {} sequence now.
 783                 pushLexState layout_left
 784                 return (T loc end ITvocurly)
 785         other -> do
 786                 setContext (Layout offset : ctx)
 787                 return (T loc end ITvocurly)
 788
 789 do_layout_left loc end _buf _len = do
 790     popLexState
 791     pushLexState bol  -- we must be at the start of a line
 792     return (T loc end ITvccurly)
 793
 794 -- -----------------------------------------------------------------------------
 795 -- LINE pragmas
 796
 797 set_line :: Int -> Action
 798 set_line code loc end buf len = do
 799   let line = parseInteger buf len 10 oct_or_dec
 800   setSrcLoc (mkSrcLoc (srcLocFile end) (fromIntegral line - 1) 0)
 801         -- subtract one: the line number refers to the *following* line
 802   popLexState
 803   pushLexState code
 804   lexToken
 805
 806 set_file :: Int -> Action
 807 set_file code loc end buf len = do
 808   let file = lexemeToFastString (stepOn buf) (len-2)
 809   setSrcLoc (mkSrcLoc file (srcLocLine end) (srcLocCol end))
 810   popLexState
 811   pushLexState code
 812   lexToken
 813
 814 -- -----------------------------------------------------------------------------
 815 -- Strings & Chars
 816
 817 -- This stuff is horrible.  I hates it.
 818
 819 lex_string_tok :: Action
 820 lex_string_tok loc end buf len = do
 821   tok <- lex_string ""
 822   end <- getSrcLoc
 823   return (T loc end tok)
 824
 825 lex_string :: String -> P Token__
 826 lex_string s = do
 827   i <- getInput
 828   case alexGetChar i of
 829     Nothing -> lit_error
 830
 831     Just ('"',i)  -> do
 832         setInput i
 833         glaexts <- extension glaExtsEnabled
 834         if glaexts
 835           then do
 836             i <- getInput
 837             case alexGetChar i of
 838               Just ('#',i) -> do
 839                    setInput i
 840                    if any (> '\xFF') s
 841                     then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
 842                     else let s' = mkFastStringNarrow (reverse s) in
 843                          -- always a narrow string/byte array
 844                          return (ITprimstring s')
 845               _other ->
 846                 return (ITstring (mkFastString (reverse s)))
 847           else
 848                 return (ITstring (mkFastString (reverse s)))
 849
 850     Just ('\\',i)
 851         | Just ('&',i) <- next -> do
 852                 setInput i; lex_string s
 853         | Just (c,i) <- next, is_space c -> do
 854                 setInput i; lex_stringgap s
 855         where next = alexGetChar i
 856
 857     Just _ -> do
 858         c <- lex_char
 859         lex_string (c:s)
 860
 861 lex_char :: P Char
 862 lex_char = do
 863   mc <- getCharOrFail
 864   case mc of
 865       '\\' -> lex_escape
 866       c | is_any c -> return c
 867       _other -> lit_error
 868
 869 lex_stringgap s = do
 870   c <- getCharOrFail
 871   case c of
 872     '\\' -> lex_string s
 873     c | is_space c -> lex_stringgap s
 874     _other -> lit_error
 875
 876
 877 lex_char_tok :: Action
 878 -- Here we are basically parsing character literals, such as 'x' or '\n'
 879 -- but, when Template Haskell is on, we additionally spot
 880 -- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
 881 -- but WIHTOUT CONSUMING the x or T part  (the parser does that).
 882 -- So we have to do two characters of lookahead: when we see 'x we need to
 883 -- see if there's a trailing quote
 884 lex_char_tok loc _end buf len = do      -- We've seen '
 885    i1 <- getInput       -- Look ahead to first character
 886    case alexGetChar i1 of
 887         Nothing -> lit_error
 888
 889         Just ('\'', i2@(end2,_)) -> do  -- We've seen ''
 890                   th_exts <- extension thEnabled
 891                   if th_exts then do
 892                         setInput i2
 893                         return (T loc end2 ITtyQuote)
 894                    else lit_error
 895
 896         Just ('\\', i2@(end2,_)) -> do  -- We've seen 'backslash
 897                   setInput i2
 898                   lit_ch <- lex_escape
 899                   mc <- getCharOrFail   -- Trailing quote
 900                   if mc == '\'' then finish_char_tok loc lit_ch
 901                                 else lit_error
 902
 903         Just (c, i2@(end2,_)) | not (is_any c) -> lit_error
 904                               | otherwise      ->
 905
 906                 -- We've seen 'x, where x is a valid character
 907                 --  (i.e. not newline etc) but not a quote or backslash
 908            case alexGetChar i2 of       -- Look ahead one more character
 909                 Nothing -> lit_error
 910                 Just ('\'', i3) -> do   -- We've seen 'x'
 911                         setInput i3
 912                         finish_char_tok loc c
 913                 _other -> do            -- We've seen 'x not followed by quote
 914                                         -- If TH is on, just parse the quote only
 915                         th_exts <- extension thEnabled
 916                         if th_exts then return (T loc (fst i1) ITvarQuote)
 917                                    else lit_error
 918
 919 finish_char_tok :: SrcLoc -> Char -> P Token
 920 finish_char_tok loc ch  -- We've already seen the closing quote
 921                         -- Just need to check for trailing #
 922   = do  glaexts <- extension glaExtsEnabled
 923         if glaexts then do
 924                 i@(end,_) <- getInput
 925                 case alexGetChar i of
 926                         Just ('#',i@(end,_)) -> do
 927                                 setInput i
 928                                 return (T loc end (ITprimchar ch))
 929                         _other ->
 930                                         return (T loc end (ITchar ch))
 931           else do end <- getSrcLoc
 932                   return (T loc end (ITchar ch))
 933
 934 lex_escape :: P Char
 935 lex_escape = do
 936   c <- getCharOrFail
 937   case c of
 938         'a'   -> return '\a'
 939         'b'   -> return '\b'
 940         'f'   -> return '\f'
 941         'n'   -> return '\n'
 942         'r'   -> return '\r'
 943         't'   -> return '\t'
 944         'v'   -> return '\v'
 945         '\\'  -> return '\\'
 946         '"'   -> return '\"'
 947         '\''  -> return '\''
 948         '^'   -> do c <- getCharOrFail
 949                     if c >= '@' && c <= '_'
 950                         then return (chr (ord c - ord '@'))
 951                         else lit_error
 952
 953         'x'   -> readNum is_hexdigit 16 hex
 954         'o'   -> readNum is_octdigit  8 oct_or_dec
 955         x | is_digit x -> readNum2 is_digit 10 oct_or_dec (oct_or_dec x)
 956
 957         c1 ->  do
 958            i <- getInput
 959            case alexGetChar i of
 960             Nothing -> lit_error
 961             Just (c2,i2) ->
 962               case alexGetChar i2 of
 963                 Nothing -> lit_error
 964                 Just (c3,i3) ->
 965                    let str = [c1,c2,c3] in
 966                    case [ (c,rest) | (p,c) <- silly_escape_chars,
 967                                      Just rest <- [maybePrefixMatch p str] ] of
 968                           (escape_char,[]):_ -> do
 969                                 setInput i3
 970                                 return escape_char
 971                           (escape_char,_:_):_ -> do
 972                                 setInput i2
 973                                 return escape_char
 974                           [] -> lit_error
 975
 976 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char
 977 readNum is_digit base conv = do
 978   c <- getCharOrFail
 979   if is_digit c
 980         then readNum2 is_digit base conv (conv c)
 981         else lit_error
 982
 983 readNum2 is_digit base conv i = do
 984   input <- getInput
 985   read i input
 986   where read i input = do
 987           case alexGetChar input of
 988             Just (c,input') | is_digit c -> do
 989                 read (i*base + conv c) input'
 990             _other -> do
 991                 setInput input
 992                 if i >= 0 && i <= 0x10FFFF
 993                    then return (chr i)
 994                    else lit_error
 995
 996 is_hexdigit c
 997         =  is_digit c
 998         || (c >= 'a' && c <= 'f')
 999         || (c >= 'A' && c <= 'F')
1000
1001 hex c | is_digit c = ord c - ord '0'
1002       | otherwise  = ord (to_lower c) - ord 'a' + 10
1003
1004 oct_or_dec c = ord c - ord '0'
1005
1006 is_octdigit c = c >= '0' && c <= '7'
1007
1008 to_lower c
1009   | c >=  'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a'))
1010   | otherwise = c
1011
1012 silly_escape_chars = [
1013         ("NUL", '\NUL'),
1014         ("SOH", '\SOH'),
1015         ("STX", '\STX'),
1016         ("ETX", '\ETX'),
1017         ("EOT", '\EOT'),
1018         ("ENQ", '\ENQ'),
1019         ("ACK", '\ACK'),
1020         ("BEL", '\BEL'),
1021         ("BS", '\BS'),
1022         ("HT", '\HT'),
1023         ("LF", '\LF'),
1024         ("VT", '\VT'),
1025         ("FF", '\FF'),
1026         ("CR", '\CR'),
1027         ("SO", '\SO'),
1028         ("SI", '\SI'),
1029         ("DLE", '\DLE'),
1030         ("DC1", '\DC1'),
1031         ("DC2", '\DC2'),
1032         ("DC3", '\DC3'),
1033         ("DC4", '\DC4'),
1034         ("NAK", '\NAK'),
1035         ("SYN", '\SYN'),
1036         ("ETB", '\ETB'),
1037         ("CAN", '\CAN'),
1038         ("EM", '\EM'),
1039         ("SUB", '\SUB'),
1040         ("ESC", '\ESC'),
1041         ("FS", '\FS'),
1042         ("GS", '\GS'),
1043         ("RS", '\RS'),
1044         ("US", '\US'),
1045         ("SP", '\SP'),
1046         ("DEL", '\DEL')
1047         ]
1048
1049 lit_error = lexError "lexical error in string/character literal"
1050
1051 getCharOrFail :: P Char
1052 getCharOrFail =  do
1053   i <- getInput
1054   case alexGetChar i of
1055         Nothing -> lexError "unexpected end-of-file in string/character literal"
1056         Just (c,i)  -> do setInput i; return c
1057
1058 -- -----------------------------------------------------------------------------
1059 -- Floats
1060
1061 readRational :: ReadS Rational -- NB: doesn't handle leading "-"
1062 readRational r = do
1063      (n,d,s) <- readFix r
1064      (k,t)   <- readExp s
1065      return ((n%1)*10^^(k-d), t)
1066  where
1067      readFix r = do
1068         (ds,s)  <- lexDecDigits r
1069         (ds',t) <- lexDotDigits s
1070         return (read (ds++ds'), length ds', t)
1071
1072      readExp (e:s) | e `elem` "eE" = readExp' s
1073      readExp s                     = return (0,s)
1074
1075      readExp' ('+':s) = readDec s
1076      readExp' ('-':s) = do
1077                         (k,t) <- readDec s
1078                         return (-k,t)
1079      readExp' s       = readDec s
1080
1081      readDec s = do
1082         (ds,r) <- nonnull isDigit s
1083         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
1084                 r)
1085
1086      lexDecDigits = nonnull isDigit
1087
1088      lexDotDigits ('.':s) = return (span isDigit s)
1089      lexDotDigits s       = return ("",s)
1090
1091      nonnull p s = do (cs@(_:_),t) <- return (span p s)
1092                       return (cs,t)
1093
1094 readRational__ :: String -> Rational -- NB: *does* handle a leading "-"
1095 readRational__ top_s
1096   = case top_s of
1097       '-' : xs -> - (read_me xs)
1098       xs       -> read_me xs
1099   where
1100     read_me s
1101       = case (do { (x,"") <- readRational s ; return x }) of
1102           [x] -> x
1103           []  -> error ("readRational__: no parse:"        ++ top_s)
1104           _   -> error ("readRational__: ambiguous parse:" ++ top_s)
1105
1106 -- -----------------------------------------------------------------------------
1107 -- The Parse Monad
1108
1109 data LayoutContext
1110   = NoLayout
1111   | Layout !Int
1112
1113 data ParseResult a
1114   = POk PState a
1115   | PFailed
1116         SrcLoc SrcLoc   -- The start and end of the text span related to
1117                         -- the error.  Might be used in environments which can
1118                         -- show this span, e.g. by highlighting it.
1119         Message         -- The error message
1120
1121 showPFailed loc1 loc2 err = hcat [ppr loc1, text ": ", err]
1122
1123 data PState = PState {
1124         buffer     :: StringBuffer,
1125         last_loc   :: SrcLoc,           -- pos of previous token
1126         last_len   :: !Int,             -- len of previous token
1127         loc        :: SrcLoc,   -- current loc (end of prev token + 1)
1128         extsBitmap :: !Int,     -- bitmap that determines permitted extensions
1129         context    :: [LayoutContext],
1130         lex_state  :: [Int]
1131      }
1132         -- last_loc and last_len are used when generating error messages,
1133         -- and in pushCurrentContext only.
1134
1135 newtype P a = P { unP :: PState -> ParseResult a }
1136
1137 instance Monad P where
1138   return = returnP
1139   (>>=) = thenP
1140   fail = failP
1141
1142 returnP :: a -> P a
1143 returnP a = P $ \s -> POk s a
1144
1145 thenP :: P a -> (a -> P b) -> P b
1146 (P m) `thenP` k = P $ \ s ->
1147         case m s of
1148                 POk s1 a          -> (unP (k a)) s1
1149                 PFailed l1 l2 err -> PFailed l1 l2 err
1150
1151 failP :: String -> P a
1152 failP msg = P $ \s -> PFailed (last_loc s) (loc s) (text msg)
1153
1154 failMsgP :: String -> P a
1155 failMsgP msg = P $ \s -> PFailed (last_loc s) (loc s) (text msg)
1156
1157 failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
1158 failLocMsgP loc1 loc2 str = P $ \s -> PFailed loc1 loc2 (text str)
1159
1160 extension :: (Int -> Bool) -> P Bool
1161 extension p = P $ \s -> POk s (p $! extsBitmap s)
1162
1163 getExts :: P Int
1164 getExts = P $ \s -> POk s (extsBitmap s)
1165
1166 setSrcLoc :: SrcLoc -> P ()
1167 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
1168
1169 -- tmp, for supporting stuff in RdrHsSyn.  The scope better not include
1170 -- any calls to the lexer, because it assumes things about the SrcLoc.
1171 setSrcLocFor :: SrcLoc -> P a -> P a
1172 setSrcLocFor new_loc scope = P $ \s@PState{ loc = old_loc } ->
1173   case unP scope s{loc=new_loc} of
1174         PFailed l1 l2 msg -> PFailed l1 l2 msg
1175         POk _ r -> POk s r
1176
1177 getSrcLoc :: P SrcLoc
1178 getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
1179
1180 setLastToken :: SrcLoc -> Int -> P ()
1181 setLastToken loc len = P $ \s -> POk s{ last_loc=loc, last_len=len } ()
1182
1183 type AlexInput = (SrcLoc,StringBuffer)
1184
1185 alexInputPrevChar :: AlexInput -> Char
1186 alexInputPrevChar (_,s) = prevChar s '\n'
1187
1188 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
1189 alexGetChar (loc,s)
1190   | atEnd s   = Nothing
1191   | otherwise = c `seq` loc' `seq` s' `seq` Just (c, (loc', s'))
1192   where c = currentChar s
1193         loc' = advanceSrcLoc loc c
1194         s'   = stepOn s
1195
1196 getInput :: P AlexInput
1197 getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b)
1198
1199 setInput :: AlexInput -> P ()
1200 setInput (l,b) = P $ \s -> POk s{ loc=l, buffer=b } ()
1201
1202 pushLexState :: Int -> P ()
1203 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
1204
1205 popLexState :: P Int
1206 popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
1207
1208 getLexState :: P Int
1209 getLexState = P $ \s@PState{ lex_state=ls:l } -> POk s ls
1210
1211 -- for reasons of efficiency, flags indicating language extensions (eg,
1212 -- -fglasgow-exts or -fparr) are represented by a bitmap stored in an unboxed
1213 -- integer
1214
1215 glaExtsBit, ffiBit, parrBit :: Int
1216 glaExtsBit = 0
1217 ffiBit     = 1
1218 parrBit    = 2
1219 arrowsBit  = 4
1220 thBit      = 5
1221 ipBit      = 6
1222
1223 glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
1224 glaExtsEnabled flags = testBit flags glaExtsBit
1225 ffiEnabled     flags = testBit flags ffiBit
1226 parrEnabled    flags = testBit flags parrBit
1227 arrowsEnabled  flags = testBit flags arrowsBit
1228 thEnabled      flags = testBit flags thBit
1229 ipEnabled      flags = testBit flags ipBit
1230
1231 -- create a parse state
1232 --
1233 mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
1234 mkPState buf loc flags  =
1235   PState {
1236       buffer     = buf,
1237       last_loc   = loc,
1238       last_len   = 0,
1239       loc        = loc,
1240       extsBitmap = fromIntegral bitmap,
1241       context    = [],
1242       lex_state  = [bol, if glaExtsEnabled bitmap then glaexts else 0]
1243         -- we begin in the layout state if toplev_layout is set
1244     }
1245     where
1246       bitmap =     glaExtsBit `setBitIf` dopt Opt_GlasgowExts flags
1247                .|. ffiBit     `setBitIf` dopt Opt_FFI         flags
1248                .|. parrBit    `setBitIf` dopt Opt_PArr        flags
1249                .|. arrowsBit  `setBitIf` dopt Opt_Arrows      flags
1250                .|. thBit      `setBitIf` dopt Opt_TH          flags
1251                .|. ipBit      `setBitIf` dopt Opt_ImplicitParams flags
1252       --
1253       setBitIf :: Int -> Bool -> Int
1254       b `setBitIf` cond | cond      = bit b
1255                         | otherwise = 0
1256
1257 getContext :: P [LayoutContext]
1258 getContext = P $ \s@PState{context=ctx} -> POk s ctx
1259
1260 setContext :: [LayoutContext] -> P ()
1261 setContext ctx = P $ \s -> POk s{context=ctx} ()
1262
1263 popContext :: P ()
1264 popContext = P $ \ s@(PState{ buffer = buf, context = ctx,
1265                            loc = loc, last_len = len, last_loc = last_loc }) ->
1266   case ctx of
1267         (_:tl) -> POk s{ context = tl } ()
1268         []     -> PFailed last_loc loc (srcParseErr buf len)
1269
1270 -- Push a new layout context at the indentation of the last token read.
1271 -- This is only used at the outer level of a module when the 'module'
1272 -- keyword is missing.
1273 pushCurrentContext :: P ()
1274 pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } ->
1275   POk s{ context = Layout (srcLocCol loc) : ctx} ()
1276
1277 getOffside :: SrcLoc -> P Ordering
1278 getOffside loc = P $ \s@PState{context=stk} ->
1279                 let ord = case stk of
1280                         (Layout n:_) -> compare (srcLocCol loc) n
1281                         _            -> GT
1282                 in POk s ord
1283
1284 -- ---------------------------------------------------------------------------
1285 -- Construct a parse error
1286
1287 srcParseErr
1288   :: StringBuffer       -- current buffer (placed just after the last token)
1289   -> Int                -- length of the previous token
1290   -> Message
1291 srcParseErr buf len
1292   = hcat [ if null token
1293              then ptext SLIT("parse error (possibly incorrect indentation)")
1294              else hcat [ptext SLIT("parse error on input "),
1295                         char '`', text token, char '\'']
1296     ]
1297   where token = lexemeToString (stepOnBy (-len) buf) len
1298
1299 -- Report a parse failure, giving the span of the previous token as
1300 -- the location of the error.  This is the entry point for errors
1301 -- detected during parsing.
1302 srcParseFail :: P a
1303 srcParseFail = P $ \PState{ buffer = buf, last_len = len,
1304                                 last_loc = last_loc, loc = loc } ->
1305     PFailed last_loc loc (srcParseErr buf len)
1306
1307 -- A lexical error is reported at a particular position in the source file,
1308 -- not over a token range.  TODO: this is slightly wrong, because we record
1309 -- the error at the character position following the one which caused the
1310 -- error.  We should somehow back up by one character.
1311 lexError :: String -> P a
1312 lexError str = do
1313   loc <- getSrcLoc
1314   failLocMsgP loc loc str
1315
1316 -- -----------------------------------------------------------------------------
1317 -- This is the top-level function: called from the parser each time a
1318 -- new token is to be read from the input.
1319
1320 lexer :: (Token -> P a) -> P a
1321 lexer cont = do
1322   tok@(T _ _ tok__) <- lexToken
1323   --trace ("token: " ++ show tok__) $ do
1324   cont tok
1325
1326 lexToken :: P Token
1327 lexToken = do
1328   inp@(loc1,buf) <- getInput
1329   sc <- getLexState
1330   exts <- getExts
1331   case alexScanUser exts inp sc of
1332     AlexEOF -> do setLastToken loc1 0
1333                   return (T loc1 loc1 ITeof)
1334     AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
1335     AlexSkip inp2 _ -> do
1336         setInput inp2
1337         lexToken
1338     AlexToken inp2@(end,buf2) len t -> do
1339         setInput inp2
1340         setLastToken loc1 len
1341         t loc1 end buf len
1342 }