ghc/compiler/parser/Lexer.x

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