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