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