compiler/parser/Lexer.x

   1 -----------------------------------------------------------------------------
   2 -- (c) The University of Glasgow, 2006
   3 --
   4 -- GHC's lexer.
   5 --
   6 -- This is a combination of an Alex-generated lexer from a regex
   7 -- definition, with some hand-coded bits.
   8 --
   9 -- Completely accurate information about token-spans within the source
  10 -- file is maintained.  Every token has a start and end SrcLoc attached to it.
  11 --
  12 -----------------------------------------------------------------------------
  13
  14 --   ToDo / known bugs:
  15 --    - Unicode
  16 --    - parsing integers is a bit slow
  17 --    - readRational is a bit slow
  18 --
  19 --   Known bugs, that were also in the previous version:
  20 --    - M... should be 3 tokens, not 1.
  21 --    - pragma-end should be only valid in a pragma
  22
  23 {
  24 {-# OPTIONS -w #-}
  25 -- The above warning supression flag is a temporary kludge.
  26 -- While working on this module you are encouraged to remove it and fix
  27 -- any warnings in the module. See
  28 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  29 -- for details
  30 --
  31 -- Note that Alex itself generates code with with some unused bindings and
  32 -- without type signatures, so removing the flag might not be possible.
  33
  34 module Lexer (
  35    Token(..), lexer, pragState, mkPState, PState(..),
  36    P(..), ParseResult(..), getSrcLoc,
  37    failLocMsgP, failSpanMsgP, srcParseFail,
  38    getMessages,
  39    popContext, pushCurrentContext, setLastToken, setSrcLoc,
  40    getLexState, popLexState, pushLexState,
  41    extension, standaloneDerivingEnabled, bangPatEnabled,
  42    addWarning
  43   ) where
  44
  45 import Bag
  46 import ErrUtils
  47 import Outputable
  48 import StringBuffer
  49 import FastString
  50 import FastTypes
  51 import SrcLoc
  52 import UniqFM
  53 import DynFlags
  54 import Ctype
  55 import Util             ( maybePrefixMatch, readRational )
  56
  57 import Control.Monad
  58 import Data.Bits
  59 import Data.Char        ( chr, ord, isSpace )
  60 import Data.Ratio
  61 import Debug.Trace
  62
  63 import Unicode ( GeneralCategory(..), generalCategory, isPrint, isUpper )
  64 }
  65
  66 $unispace    = \x05 -- Trick Alex into handling Unicode. See alexGetChar.
  67 $whitechar   = [\ \n\r\f\v $unispace]
  68 $white_no_nl = $whitechar # \n
  69 $tab         = \t
  70
  71 $ascdigit  = 0-9
  72 $unidigit  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
  73 $decdigit  = $ascdigit -- for now, should really be $digit (ToDo)
  74 $digit     = [$ascdigit $unidigit]
  75
  76 $special   = [\(\)\,\;\[\]\`\{\}]
  77 $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
  78 $unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
  79 $symbol    = [$ascsymbol $unisymbol] # [$special \_\:\"\']
  80
  81 $unilarge  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
  82 $asclarge  = [A-Z]
  83 $large     = [$asclarge $unilarge]
  84
  85 $unismall  = \x02 -- Trick Alex into handling Unicode. See alexGetChar.
  86 $ascsmall  = [a-z]
  87 $small     = [$ascsmall $unismall \_]
  88
  89 $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar.
  90 $graphic   = [$small $large $symbol $digit $special $unigraphic \:\"\']
  91
  92 $octit     = 0-7
  93 $hexit     = [$decdigit A-F a-f]
  94 $symchar   = [$symbol \:]
  95 $nl        = [\n\r]
  96 $idchar    = [$small $large $digit \']
  97
  98 $docsym    = [\| \^ \* \$]
  99
 100 @varid     = $small $idchar*
 101 @conid     = $large $idchar*
 102
 103 @varsym    = $symbol $symchar*
 104 @consym    = \: $symchar*
 105
 106 @decimal     = $decdigit+
 107 @octal       = $octit+
 108 @hexadecimal = $hexit+
 109 @exponent    = [eE] [\-\+]? @decimal
 110
 111 -- we support the hierarchical module name extension:
 112 @qual = (@conid \.)+
 113
 114 @floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
 115
 116 -- normal signed numerical literals can only be explicitly negative,
 117 -- not explicitly positive (contrast @exponent)
 118 @negative = \-
 119 @signed = @negative ?
 120
 121 haskell :-
 122
 123 -- everywhere: skip whitespace and comments
 124 $white_no_nl+                           ;
 125 $tab+         { warn Opt_WarnTabs (text "Tab character") }
 126
 127 -- Everywhere: deal with nested comments.  We explicitly rule out
 128 -- pragmas, "{-#", so that we don't accidentally treat them as comments.
 129 -- (this can happen even though pragmas will normally take precedence due to
 130 -- longest-match, because pragmas aren't valid in every state, but comments
 131 -- are). We also rule out nested Haddock comments, if the -haddock flag is
 132 -- set.
 133
 134 "{-" / { isNormalComment } { nested_comment lexToken }
 135
 136 -- Single-line comments are a bit tricky.  Haskell 98 says that two or
 137 -- more dashes followed by a symbol should be parsed as a varsym, so we
 138 -- have to exclude those.
 139
 140 -- Since Haddock comments aren't valid in every state, we need to rule them
 141 -- out here.
 142
 143 -- The following two rules match comments that begin with two dashes, but
 144 -- continue with a different character. The rules test that this character
 145 -- is not a symbol (in which case we'd have a varsym), and that it's not a
 146 -- space followed by a Haddock comment symbol (docsym) (in which case we'd
 147 -- have a Haddock comment). The rules then munch the rest of the line.
 148
 149 "-- " ~[$docsym \#] .* ;
 150 "--" [^$symbol : \ ] .* ;
 151
 152 -- Next, match Haddock comments if no -haddock flag
 153
 154 "-- " [$docsym \#] .* / { ifExtension (not . haddockEnabled) } ;
 155
 156 -- Now, when we've matched comments that begin with 2 dashes and continue
 157 -- with a different character, we need to match comments that begin with three
 158 -- or more dashes (which clearly can't be Haddock comments). We only need to
 159 -- make sure that the first non-dash character isn't a symbol, and munch the
 160 -- rest of the line.
 161
 162 "---"\-* [^$symbol :] .* ;
 163
 164 -- Since the previous rules all match dashes followed by at least one
 165 -- character, we also need to match a whole line filled with just dashes.
 166
 167 "--"\-* / { atEOL } ;
 168
 169 -- We need this rule since none of the other single line comment rules
 170 -- actually match this case.
 171
 172 "-- " / { atEOL } ;
 173
 174 -- 'bol' state: beginning of a line.  Slurp up all the whitespace (including
 175 -- blank lines) until we find a non-whitespace character, then do layout
 176 -- processing.
 177 --
 178 -- One slight wibble here: what if the line begins with {-#? In
 179 -- theory, we have to lex the pragma to see if it's one we recognise,
 180 -- and if it is, then we backtrack and do_bol, otherwise we treat it
 181 -- as a nested comment.  We don't bother with this: if the line begins
 182 -- with {-#, then we'll assume it's a pragma we know about and go for do_bol.
 183 <bol> {
 184   \n                                    ;
 185   ^\# (line)?                           { begin line_prag1 }
 186   ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently
 187   ^\# \! .* \n                          ; -- #!, for scripts
 188   ()                                    { do_bol }
 189 }
 190
 191 -- after a layout keyword (let, where, do, of), we begin a new layout
 192 -- context if the curly brace is missing.
 193 -- Careful! This stuff is quite delicate.
 194 <layout, layout_do> {
 195   \{ / { notFollowedBy '-' }            { pop_and open_brace }
 196         -- we might encounter {-# here, but {- has been handled already
 197   \n                                    ;
 198   ^\# (line)?                           { begin line_prag1 }
 199 }
 200
 201 -- do is treated in a subtly different way, see new_layout_context
 202 <layout>    ()                          { new_layout_context True }
 203 <layout_do> ()                          { new_layout_context False }
 204
 205 -- after a new layout context which was found to be to the left of the
 206 -- previous context, we have generated a '{' token, and we now need to
 207 -- generate a matching '}' token.
 208 <layout_left>  ()                       { do_layout_left }
 209
 210 <0,option_prags> \n                             { begin bol }
 211
 212 "{-#" $whitechar* (line|LINE)           { begin line_prag2 }
 213
 214 -- single-line line pragmas, of the form
 215 --    # <line> "<file>" <extra-stuff> \n
 216 <line_prag1> $decdigit+                 { setLine line_prag1a }
 217 <line_prag1a> \" [$graphic \ ]* \"      { setFile line_prag1b }
 218 <line_prag1b> .*                        { pop }
 219
 220 -- Haskell-style line pragmas, of the form
 221 --    {-# LINE <line> "<file>" #-}
 222 <line_prag2> $decdigit+                 { setLine line_prag2a }
 223 <line_prag2a> \" [$graphic \ ]* \"      { setFile line_prag2b }
 224 <line_prag2b> "#-}"|"-}"                { pop }
 225    -- NOTE: accept -} at the end of a LINE pragma, for compatibility
 226    -- with older versions of GHC which generated these.
 227
 228 -- We only want RULES pragmas to be picked up when explicit forall
 229 -- syntax is enabled is on, because the contents of the pragma always
 230 -- uses it. If it's not on then we're sure to get a parse error.
 231 -- (ToDo: we should really emit a warning when ignoring pragmas)
 232 -- XXX Now that we can enable this without the -fglasgow-exts hammer,
 233 -- is it better just to let the parse error happen?
 234 <0>
 235   "{-#" $whitechar* (RULES|rules) / { ifExtension explicitForallEnabled } { token ITrules_prag }
 236
 237 <0,option_prags> {
 238   "{-#" $whitechar* (INLINE|inline)     { token (ITinline_prag True) }
 239   "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline)
 240                                         { token (ITinline_prag False) }
 241   "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
 242                                         { token ITspec_prag }
 243   "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
 244         $whitechar* (INLINE|inline)     { token (ITspec_inline_prag True) }
 245   "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
 246         $whitechar* (NO(T?)INLINE|no(t?)inline)
 247                                         { token (ITspec_inline_prag False) }
 248   "{-#" $whitechar* (SOURCE|source)     { token ITsource_prag }
 249   "{-#" $whitechar* (DEPRECATED|deprecated)
 250                                         { token ITdeprecated_prag }
 251   "{-#" $whitechar* (SCC|scc)           { token ITscc_prag }
 252   "{-#" $whitechar* (GENERATED|generated)
 253                                         { token ITgenerated_prag }
 254   "{-#" $whitechar* (CORE|core)         { token ITcore_prag }
 255   "{-#" $whitechar* (UNPACK|unpack)     { token ITunpack_prag }
 256
 257  "{-#"                                 { nested_comment lexToken }
 258
 259   -- ToDo: should only be valid inside a pragma:
 260   "#-}"                                 { token ITclose_prag}
 261 }
 262
 263 <option_prags> {
 264   "{-#"  $whitechar* (OPTIONS|options)   { lex_string_prag IToptions_prag }
 265   "{-#"  $whitechar* (OPTIONS_GHC|options_ghc)
 266                                         { lex_string_prag IToptions_prag }
 267   "{-#"  $whitechar* (OPTIONS_HADDOCK|options_haddock)
 268                                          { lex_string_prag ITdocOptions }
 269   "-- #"                                 { multiline_doc_comment }
 270   "{-#"  $whitechar* (LANGUAGE|language) { token ITlanguage_prag }
 271   "{-#"  $whitechar* (INCLUDE|include)   { lex_string_prag ITinclude_prag }
 272 }
 273
 274 <0> {
 275   "-- #" .* ;
 276 }
 277
 278 <0,option_prags> {
 279         -- This is to catch things like {-# OPTIONS OPTIONS_HUGS ...
 280   "{-#" $whitechar* $idchar+            { nested_comment lexToken }
 281 }
 282
 283 -- '0' state: ordinary lexemes
 284
 285 -- Haddock comments
 286
 287 <0> {
 288   "-- " $docsym      / { ifExtension haddockEnabled } { multiline_doc_comment }
 289   "{-" \ ? $docsym   / { ifExtension haddockEnabled } { nested_doc_comment }
 290 }
 291
 292 -- "special" symbols
 293
 294 <0> {
 295   "[:" / { ifExtension parrEnabled }    { token ITopabrack }
 296   ":]" / { ifExtension parrEnabled }    { token ITcpabrack }
 297 }
 298
 299 <0> {
 300   "[|"      / { ifExtension thEnabled } { token ITopenExpQuote }
 301   "[e|"     / { ifExtension thEnabled } { token ITopenExpQuote }
 302   "[p|"     / { ifExtension thEnabled } { token ITopenPatQuote }
 303   "[d|"     / { ifExtension thEnabled } { layout_token ITopenDecQuote }
 304   "[t|"     / { ifExtension thEnabled } { token ITopenTypQuote }
 305   "|]"      / { ifExtension thEnabled } { token ITcloseQuote }
 306   \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
 307   "$("      / { ifExtension thEnabled } { token ITparenEscape }
 308
 309   "[$" @varid "|"  / { ifExtension qqEnabled }
 310                      { lex_quasiquote_tok }
 311 }
 312
 313 <0> {
 314   "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
 315                                         { special IToparenbar }
 316   "|)" / { ifExtension arrowsEnabled }  { special ITcparenbar }
 317 }
 318
 319 <0> {
 320   \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
 321 }
 322
 323 <0> {
 324   "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol }
 325          { token IToubxparen }
 326   "#)" / { ifExtension unboxedTuplesEnabled }
 327          { token ITcubxparen }
 328 }
 329
 330 <0> {
 331   "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
 332   "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
 333 }
 334
 335 <0,option_prags> {
 336   \(                                    { special IToparen }
 337   \)                                    { special ITcparen }
 338   \[                                    { special ITobrack }
 339   \]                                    { special ITcbrack }
 340   \,                                    { special ITcomma }
 341   \;                                    { special ITsemi }
 342   \`                                    { special ITbackquote }
 343
 344   \{                                    { open_brace }
 345   \}                                    { close_brace }
 346 }
 347
 348 <0,option_prags> {
 349   @qual @varid                  { idtoken qvarid }
 350   @qual @conid                  { idtoken qconid }
 351   @varid                        { varid }
 352   @conid                        { idtoken conid }
 353 }
 354
 355 <0> {
 356   @qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
 357   @qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
 358   @varid "#"+       / { ifExtension magicHashEnabled } { varid }
 359   @conid "#"+       / { ifExtension magicHashEnabled } { idtoken conid }
 360 }
 361
 362 -- ToDo: M.(,,,)
 363
 364 <0> {
 365   @qual @varsym                 { idtoken qvarsym }
 366   @qual @consym                 { idtoken qconsym }
 367   @varsym                       { varsym }
 368   @consym                       { consym }
 369 }
 370
 371 -- For the normal boxed literals we need to be careful
 372 -- when trying to be close to Haskell98
 373 <0> {
 374   -- Normal integral literals (:: Num a => a, from Integer)
 375   @decimal           { tok_num positive 0 0 decimal }
 376   0[oO] @octal       { tok_num positive 2 2 octal }
 377   0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal }
 378
 379   -- Normal rational literals (:: Fractional a => a, from Rational)
 380   @floating_point    { strtoken tok_float }
 381 }
 382
 383 <0> {
 384   -- Unboxed ints (:: Int#) and words (:: Word#)
 385   -- It's simpler (and faster?) to give separate cases to the negatives,
 386   -- especially considering octal/hexadecimal prefixes.
 387   @decimal                     \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
 388   0[oO] @octal                 \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
 389   0[xX] @hexadecimal           \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
 390   @negative @decimal           \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
 391   @negative 0[oO] @octal       \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
 392   @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
 393
 394   @decimal                     \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal }
 395   0[oO] @octal                 \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }
 396   0[xX] @hexadecimal           \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }
 397
 398   -- Unboxed floats and doubles (:: Float#, :: Double#)
 399   -- prim_{float,double} work with signed literals
 400   @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }
 401   @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble }
 402 }
 403
 404 -- Strings and chars are lexed by hand-written code.  The reason is
 405 -- that even if we recognise the string or char here in the regex
 406 -- lexer, we would still have to parse the string afterward in order
 407 -- to convert it to a String.
 408 <0> {
 409   \'                            { lex_char_tok }
 410   \"                            { lex_string_tok }
 411 }
 412
 413 {
 414 -- -----------------------------------------------------------------------------
 415 -- The token type
 416
 417 data Token
 418   = ITas                        -- Haskell keywords
 419   | ITcase
 420   | ITclass
 421   | ITdata
 422   | ITdefault
 423   | ITderiving
 424   | ITdo
 425   | ITelse
 426   | IThiding
 427   | ITif
 428   | ITimport
 429   | ITin
 430   | ITinfix
 431   | ITinfixl
 432   | ITinfixr
 433   | ITinstance
 434   | ITlet
 435   | ITmodule
 436   | ITnewtype
 437   | ITof
 438   | ITqualified
 439   | ITthen
 440   | ITtype
 441   | ITwhere
 442   | ITscc                       -- ToDo: remove (we use {-# SCC "..." #-} now)
 443
 444   | ITforall                    -- GHC extension keywords
 445   | ITforeign
 446   | ITexport
 447   | ITlabel
 448   | ITdynamic
 449   | ITsafe
 450   | ITthreadsafe
 451   | ITunsafe
 452   | ITstdcallconv
 453   | ITccallconv
 454   | ITdotnet
 455   | ITmdo
 456   | ITfamily
 457   | ITgroup
 458   | ITby
 459   | ITusing
 460
 461         -- Pragmas
 462   | ITinline_prag Bool          -- True <=> INLINE, False <=> NOINLINE
 463   | ITspec_prag                 -- SPECIALISE
 464   | ITspec_inline_prag Bool     -- SPECIALISE INLINE (or NOINLINE)
 465   | ITsource_prag
 466   | ITrules_prag
 467   | ITdeprecated_prag
 468   | ITline_prag
 469   | ITscc_prag
 470   | ITgenerated_prag
 471   | ITcore_prag                 -- hdaume: core annotations
 472   | ITunpack_prag
 473   | ITclose_prag
 474   | IToptions_prag String
 475   | ITinclude_prag String
 476   | ITlanguage_prag
 477
 478   | ITdotdot                    -- reserved symbols
 479   | ITcolon
 480   | ITdcolon
 481   | ITequal
 482   | ITlam
 483   | ITvbar
 484   | ITlarrow
 485   | ITrarrow
 486   | ITat
 487   | ITtilde
 488   | ITdarrow
 489   | ITminus
 490   | ITbang
 491   | ITstar
 492   | ITdot
 493
 494   | ITbiglam                    -- GHC-extension symbols
 495
 496   | ITocurly                    -- special symbols
 497   | ITccurly
 498   | ITocurlybar                 -- {|, for type applications
 499   | ITccurlybar                 -- |}, for type applications
 500   | ITvocurly
 501   | ITvccurly
 502   | ITobrack
 503   | ITopabrack                  -- [:, for parallel arrays with -XParr
 504   | ITcpabrack                  -- :], for parallel arrays with -XParr
 505   | ITcbrack
 506   | IToparen
 507   | ITcparen
 508   | IToubxparen
 509   | ITcubxparen
 510   | ITsemi
 511   | ITcomma
 512   | ITunderscore
 513   | ITbackquote
 514
 515   | ITvarid   FastString        -- identifiers
 516   | ITconid   FastString
 517   | ITvarsym  FastString
 518   | ITconsym  FastString
 519   | ITqvarid  (FastString,FastString)
 520   | ITqconid  (FastString,FastString)
 521   | ITqvarsym (FastString,FastString)
 522   | ITqconsym (FastString,FastString)
 523
 524   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
 525
 526   | ITpragma StringBuffer
 527
 528   | ITchar       Char
 529   | ITstring     FastString
 530   | ITinteger    Integer
 531   | ITrational   Rational
 532
 533   | ITprimchar   Char
 534   | ITprimstring FastString
 535   | ITprimint    Integer
 536   | ITprimword   Integer
 537   | ITprimfloat  Rational
 538   | ITprimdouble Rational
 539
 540   -- MetaHaskell extension tokens
 541   | ITopenExpQuote              --  [| or [e|
 542   | ITopenPatQuote              --  [p|
 543   | ITopenDecQuote              --  [d|
 544   | ITopenTypQuote              --  [t|
 545   | ITcloseQuote                --  |]
 546   | ITidEscape   FastString     --  $x
 547   | ITparenEscape               --  $(
 548   | ITvarQuote                  --  '
 549   | ITtyQuote                   --  ''
 550   | ITquasiQuote (FastString,FastString,SrcSpan) --  [:...|...|]
 551
 552   -- Arrow notation extension
 553   | ITproc
 554   | ITrec
 555   | IToparenbar                 --  (|
 556   | ITcparenbar                 --  |)
 557   | ITlarrowtail                --  -<
 558   | ITrarrowtail                --  >-
 559   | ITLarrowtail                --  -<<
 560   | ITRarrowtail                --  >>-
 561
 562   | ITunknown String            -- Used when the lexer can't make sense of it
 563   | ITeof                       -- end of file token
 564
 565   -- Documentation annotations
 566   | ITdocCommentNext  String     -- something beginning '-- |'
 567   | ITdocCommentPrev  String     -- something beginning '-- ^'
 568   | ITdocCommentNamed String     -- something beginning '-- $'
 569   | ITdocSection      Int String -- a section heading
 570   | ITdocOptions      String     -- doc options (prune, ignore-exports, etc)
 571   | ITdocOptionsOld   String     -- doc options declared "-- # ..."-style
 572
 573 #ifdef DEBUG
 574   deriving Show -- debugging
 575 #endif
 576
 577 {-
 578 isSpecial :: Token -> Bool
 579 -- If we see M.x, where x is a keyword, but
 580 -- is special, we treat is as just plain M.x,
 581 -- not as a keyword.
 582 isSpecial ITas          = True
 583 isSpecial IThiding      = True
 584 isSpecial ITqualified   = True
 585 isSpecial ITforall      = True
 586 isSpecial ITexport      = True
 587 isSpecial ITlabel       = True
 588 isSpecial ITdynamic     = True
 589 isSpecial ITsafe        = True
 590 isSpecial ITthreadsafe  = True
 591 isSpecial ITunsafe      = True
 592 isSpecial ITccallconv   = True
 593 isSpecial ITstdcallconv = True
 594 isSpecial ITmdo         = True
 595 isSpecial ITfamily      = True
 596 isSpecial ITgroup   = True
 597 isSpecial ITby      = True
 598 isSpecial ITusing   = True
 599 isSpecial _             = False
 600 -}
 601
 602 -- the bitmap provided as the third component indicates whether the
 603 -- corresponding extension keyword is valid under the extension options
 604 -- provided to the compiler; if the extension corresponding to *any* of the
 605 -- bits set in the bitmap is enabled, the keyword is valid (this setup
 606 -- facilitates using a keyword in two different extensions that can be
 607 -- activated independently)
 608 --
 609 reservedWordsFM = listToUFM $
 610         map (\(x, y, z) -> (mkFastString x, (y, z)))
 611        [( "_",          ITunderscore,   0 ),
 612         ( "as",         ITas,           0 ),
 613         ( "case",       ITcase,         0 ),
 614         ( "class",      ITclass,        0 ),
 615         ( "data",       ITdata,         0 ),
 616         ( "default",    ITdefault,      0 ),
 617         ( "deriving",   ITderiving,     0 ),
 618         ( "do",         ITdo,           0 ),
 619         ( "else",       ITelse,         0 ),
 620         ( "hiding",     IThiding,       0 ),
 621         ( "if",         ITif,           0 ),
 622         ( "import",     ITimport,       0 ),
 623         ( "in",         ITin,           0 ),
 624         ( "infix",      ITinfix,        0 ),
 625         ( "infixl",     ITinfixl,       0 ),
 626         ( "infixr",     ITinfixr,       0 ),
 627         ( "instance",   ITinstance,     0 ),
 628         ( "let",        ITlet,          0 ),
 629         ( "module",     ITmodule,       0 ),
 630         ( "newtype",    ITnewtype,      0 ),
 631         ( "of",         ITof,           0 ),
 632         ( "qualified",  ITqualified,    0 ),
 633         ( "then",       ITthen,         0 ),
 634         ( "type",       ITtype,         0 ),
 635         ( "where",      ITwhere,        0 ),
 636         ( "_scc_",      ITscc,          0 ),            -- ToDo: remove
 637
 638     ( "forall", ITforall,        bit explicitForallBit),
 639         ( "mdo",        ITmdo,           bit recursiveDoBit),
 640         ( "family",     ITfamily,        bit tyFamBit),
 641     ( "group",  ITgroup,     bit transformComprehensionsBit),
 642     ( "by",     ITby,        bit transformComprehensionsBit),
 643     ( "using",  ITusing,     bit transformComprehensionsBit),
 644
 645         ( "foreign",    ITforeign,       bit ffiBit),
 646         ( "export",     ITexport,        bit ffiBit),
 647         ( "label",      ITlabel,         bit ffiBit),
 648         ( "dynamic",    ITdynamic,       bit ffiBit),
 649         ( "safe",       ITsafe,          bit ffiBit),
 650         ( "threadsafe", ITthreadsafe,    bit ffiBit),
 651         ( "unsafe",     ITunsafe,        bit ffiBit),
 652         ( "stdcall",    ITstdcallconv,   bit ffiBit),
 653         ( "ccall",      ITccallconv,     bit ffiBit),
 654         ( "dotnet",     ITdotnet,        bit ffiBit),
 655
 656         ( "rec",        ITrec,           bit arrowsBit),
 657         ( "proc",       ITproc,          bit arrowsBit)
 658      ]
 659
 660 reservedSymsFM :: UniqFM (Token, Int -> Bool)
 661 reservedSymsFM = listToUFM $
 662     map (\ (x,y,z) -> (mkFastString x,(y,z)))
 663       [ ("..",  ITdotdot,   always)
 664         -- (:) is a reserved op, meaning only list cons
 665        ,(":",   ITcolon,    always)
 666        ,("::",  ITdcolon,   always)
 667        ,("=",   ITequal,    always)
 668        ,("\\",  ITlam,      always)
 669        ,("|",   ITvbar,     always)
 670        ,("<-",  ITlarrow,   always)
 671        ,("->",  ITrarrow,   always)
 672        ,("@",   ITat,       always)
 673        ,("~",   ITtilde,    always)
 674        ,("=>",  ITdarrow,   always)
 675        ,("-",   ITminus,    always)
 676        ,("!",   ITbang,     always)
 677
 678         -- For data T (a::*) = MkT
 679        ,("*", ITstar, \i -> kindSigsEnabled i || tyFamEnabled i)
 680         -- For 'forall a . t'
 681        ,(".", ITdot, explicitForallEnabled)
 682
 683        ,("-<",  ITlarrowtail, arrowsEnabled)
 684        ,(">-",  ITrarrowtail, arrowsEnabled)
 685        ,("-<<", ITLarrowtail, arrowsEnabled)
 686        ,(">>-", ITRarrowtail, arrowsEnabled)
 687
 688 #if __GLASGOW_HASKELL__ >= 605
 689        ,("∷",   ITdcolon, unicodeSyntaxEnabled)
 690        ,("⇒",   ITdarrow, unicodeSyntaxEnabled)
 691        ,("∀",   ITforall, \i -> unicodeSyntaxEnabled i &&
 692                                 explicitForallEnabled i)
 693        ,("→",   ITrarrow, unicodeSyntaxEnabled)
 694        ,("←",   ITlarrow, unicodeSyntaxEnabled)
 695        ,("⋯",   ITdotdot, unicodeSyntaxEnabled)
 696         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
 697         -- form part of a large operator.  This would let us have a better
 698         -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
 699 #endif
 700        ]
 701
 702 -- -----------------------------------------------------------------------------
 703 -- Lexer actions
 704
 705 type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
 706
 707 special :: Token -> Action
 708 special tok span _buf _len = return (L span tok)
 709
 710 token, layout_token :: Token -> Action
 711 token t span _buf _len = return (L span t)
 712 layout_token t span _buf _len = pushLexState layout >> return (L span t)
 713
 714 idtoken :: (StringBuffer -> Int -> Token) -> Action
 715 idtoken f span buf len = return (L span $! (f buf len))
 716
 717 skip_one_varid :: (FastString -> Token) -> Action
 718 skip_one_varid f span buf len
 719   = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
 720
 721 strtoken :: (String -> Token) -> Action
 722 strtoken f span buf len =
 723   return (L span $! (f $! lexemeToString buf len))
 724
 725 init_strtoken :: Int -> (String -> Token) -> Action
 726 -- like strtoken, but drops the last N character(s)
 727 init_strtoken drop f span buf len =
 728   return (L span $! (f $! lexemeToString buf (len-drop)))
 729
 730 begin :: Int -> Action
 731 begin code _span _str _len = do pushLexState code; lexToken
 732
 733 pop :: Action
 734 pop _span _buf _len = do popLexState; lexToken
 735
 736 pop_and :: Action -> Action
 737 pop_and act span buf len = do popLexState; act span buf len
 738
 739 {-# INLINE nextCharIs #-}
 740 nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
 741
 742 notFollowedBy char _ _ _ (AI _ _ buf)
 743   = nextCharIs buf (/=char)
 744
 745 notFollowedBySymbol _ _ _ (AI _ _ buf)
 746   = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
 747
 748 -- We must reject doc comments as being ordinary comments everywhere.
 749 -- In some cases the doc comment will be selected as the lexeme due to
 750 -- maximal munch, but not always, because the nested comment rule is
 751 -- valid in all states, but the doc-comment rules are only valid in
 752 -- the non-layout states.
 753 isNormalComment bits _ _ (AI _ _ buf)
 754   | haddockEnabled bits = notFollowedByDocOrPragma
 755   | otherwise           = nextCharIs buf (/='#')
 756   where
 757     notFollowedByDocOrPragma
 758        = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
 759
 760 spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
 761
 762 {-
 763 haddockDisabledAnd p bits _ _ (AI _ _ buf)
 764   = if haddockEnabled bits then False else (p buf)
 765 -}
 766
 767 atEOL _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf == '\n'
 768
 769 ifExtension pred bits _ _ _ = pred bits
 770
 771 multiline_doc_comment :: Action
 772 multiline_doc_comment span buf _len = withLexedDocType (worker "")
 773   where
 774     worker commentAcc input docType oneLine = case alexGetChar input of
 775       Just ('\n', input')
 776         | oneLine -> docCommentEnd input commentAcc docType buf span
 777         | otherwise -> case checkIfCommentLine input' of
 778           Just input -> worker ('\n':commentAcc) input docType False
 779           Nothing -> docCommentEnd input commentAcc docType buf span
 780       Just (c, input) -> worker (c:commentAcc) input docType oneLine
 781       Nothing -> docCommentEnd input commentAcc docType buf span
 782
 783     checkIfCommentLine input = check (dropNonNewlineSpace input)
 784       where
 785         check input = case alexGetChar input of
 786           Just ('-', input) -> case alexGetChar input of
 787             Just ('-', input) -> case alexGetChar input of
 788               Just (c, _) | c /= '-' -> Just input
 789               _ -> Nothing
 790             _ -> Nothing
 791           _ -> Nothing
 792
 793         dropNonNewlineSpace input = case alexGetChar input of
 794           Just (c, input')
 795             | isSpace c && c /= '\n' -> dropNonNewlineSpace input'
 796             | otherwise -> input
 797           Nothing -> input
 798
 799 {-
 800   nested comments require traversing by hand, they can't be parsed
 801   using regular expressions.
 802 -}
 803 nested_comment :: P (Located Token) -> Action
 804 nested_comment cont span _str _len = do
 805   input <- getInput
 806   go (1::Int) input
 807   where
 808     go 0 input = do setInput input; cont
 809     go n input = case alexGetChar input of
 810       Nothing -> errBrace input span
 811       Just ('-',input) -> case alexGetChar input of
 812         Nothing  -> errBrace input span
 813         Just ('\125',input) -> go (n-1) input
 814         Just (_,_)          -> go n input
 815       Just ('\123',input) -> case alexGetChar input of
 816         Nothing  -> errBrace input span
 817         Just ('-',input) -> go (n+1) input
 818         Just (_,_)       -> go n input
 819       Just (_,input) -> go n input
 820
 821 nested_doc_comment :: Action
 822 nested_doc_comment span buf _len = withLexedDocType (go "")
 823   where
 824     go commentAcc input docType _ = case alexGetChar input of
 825       Nothing -> errBrace input span
 826       Just ('-',input) -> case alexGetChar input of
 827         Nothing -> errBrace input span
 828         Just ('\125',input) ->
 829           docCommentEnd input commentAcc docType buf span
 830         Just (_,_) -> go ('-':commentAcc) input docType False
 831       Just ('\123', input) -> case alexGetChar input of
 832         Nothing  -> errBrace input span
 833         Just ('-',input) -> do
 834           setInput input
 835           let cont = do input <- getInput; go commentAcc input docType False
 836           nested_comment cont span buf _len
 837         Just (_,_) -> go ('\123':commentAcc) input docType False
 838       Just (c,input) -> go (c:commentAcc) input docType False
 839
 840 withLexedDocType lexDocComment = do
 841   input@(AI _ _ buf) <- getInput
 842   case prevChar buf ' ' of
 843     '|' -> lexDocComment input ITdocCommentNext False
 844     '^' -> lexDocComment input ITdocCommentPrev False
 845     '$' -> lexDocComment input ITdocCommentNamed False
 846     '*' -> lexDocSection 1 input
 847     '#' -> lexDocComment input ITdocOptionsOld False
 848  where
 849     lexDocSection n input = case alexGetChar input of
 850       Just ('*', input) -> lexDocSection (n+1) input
 851       Just (_,   _)     -> lexDocComment input (ITdocSection n) True
 852       Nothing -> do setInput input; lexToken -- eof reached, lex it normally
 853
 854 -- docCommentEnd
 855 -------------------------------------------------------------------------------
 856 -- This function is quite tricky. We can't just return a new token, we also
 857 -- need to update the state of the parser. Why? Because the token is longer
 858 -- than what was lexed by Alex, and the lexToken function doesn't know this, so
 859 -- it writes the wrong token length to the parser state. This function is
 860 -- called afterwards, so it can just update the state.
 861
 862 -- This is complicated by the fact that Haddock tokens can span multiple lines,
 863 -- which is something that the original lexer didn't account for.
 864 -- I have added last_line_len in the parser state which represents the length
 865 -- of the part of the token that is on the last line. It is now used for layout
 866 -- calculation in pushCurrentContext instead of last_len. last_len is, like it
 867 -- was before, the full length of the token, and it is now only used for error
 868 -- messages. /Waern
 869
 870 docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
 871                  SrcSpan -> P (Located Token)
 872 docCommentEnd input commentAcc docType buf span = do
 873   setInput input
 874   let (AI loc last_offs nextBuf) = input
 875       comment = reverse commentAcc
 876       span' = mkSrcSpan (srcSpanStart span) loc
 877       last_len = byteDiff buf nextBuf
 878
 879       last_line_len = if (last_offs - last_len < 0)
 880         then last_offs
 881         else last_len
 882
 883   span `seq` setLastToken span' last_len last_line_len
 884   return (L span' (docType comment))
 885
 886 errBrace (AI end _ _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
 887
 888 open_brace, close_brace :: Action
 889 open_brace span _str _len = do
 890   ctx <- getContext
 891   setContext (NoLayout:ctx)
 892   return (L span ITocurly)
 893 close_brace span _str _len = do
 894   popContext
 895   return (L span ITccurly)
 896
 897 qvarid buf len = ITqvarid $! splitQualName buf len
 898 qconid buf len = ITqconid $! splitQualName buf len
 899
 900 splitQualName :: StringBuffer -> Int -> (FastString,FastString)
 901 -- takes a StringBuffer and a length, and returns the module name
 902 -- and identifier parts of a qualified name.  Splits at the *last* dot,
 903 -- because of hierarchical module names.
 904 splitQualName orig_buf len = split orig_buf orig_buf
 905   where
 906     split buf dot_buf
 907         | orig_buf `byteDiff` buf >= len  = done dot_buf
 908         | c == '.'                        = found_dot buf'
 909         | otherwise                       = split buf' dot_buf
 910       where
 911        (c,buf') = nextChar buf
 912
 913     -- careful, we might get names like M....
 914     -- so, if the character after the dot is not upper-case, this is
 915     -- the end of the qualifier part.
 916     found_dot buf -- buf points after the '.'
 917         | isUpper c    = split buf' buf
 918         | otherwise    = done buf
 919       where
 920        (c,buf') = nextChar buf
 921
 922     done dot_buf =
 923         (lexemeToFastString orig_buf (qual_size - 1),
 924          lexemeToFastString dot_buf (len - qual_size))
 925       where
 926         qual_size = orig_buf `byteDiff` dot_buf
 927
 928 varid span buf len =
 929   fs `seq`
 930   case lookupUFM reservedWordsFM fs of
 931         Just (keyword,0)    -> do
 932                 maybe_layout keyword
 933                 return (L span keyword)
 934         Just (keyword,exts) -> do
 935                 b <- extension (\i -> exts .&. i /= 0)
 936                 if b then do maybe_layout keyword
 937                              return (L span keyword)
 938                      else return (L span (ITvarid fs))
 939         _other -> return (L span (ITvarid fs))
 940   where
 941         fs = lexemeToFastString buf len
 942
 943 conid buf len = ITconid fs
 944   where fs = lexemeToFastString buf len
 945
 946 qvarsym buf len = ITqvarsym $! splitQualName buf len
 947 qconsym buf len = ITqconsym $! splitQualName buf len
 948
 949 varsym = sym ITvarsym
 950 consym = sym ITconsym
 951
 952 sym con span buf len =
 953   case lookupUFM reservedSymsFM fs of
 954         Just (keyword,exts) -> do
 955                 b <- extension exts
 956                 if b then return (L span keyword)
 957                      else return (L span $! con fs)
 958         _other -> return (L span $! con fs)
 959   where
 960         fs = lexemeToFastString buf len
 961
 962 -- Variations on the integral numeric literal.
 963 tok_integral :: (Integer -> Token)
 964      -> (Integer -> Integer)
 965  --    -> (StringBuffer -> StringBuffer) -> (Int -> Int)
 966      -> Int -> Int
 967      -> (Integer, (Char->Int)) -> Action
 968 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len =
 969   return $ L span $ itint $! transint $ parseUnsignedInteger
 970      (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
 971
 972 -- some conveniences for use with tok_integral
 973 tok_num = tok_integral ITinteger
 974 tok_primint = tok_integral ITprimint
 975 tok_primword = tok_integral ITprimword positive
 976 positive = id
 977 negative = negate
 978 decimal = (10,octDecDigit)
 979 octal = (8,octDecDigit)
 980 hexadecimal = (16,hexDigit)
 981
 982 -- readRational can understand negative rationals, exponents, everything.
 983 tok_float        str = ITrational   $! readRational str
 984 tok_primfloat    str = ITprimfloat  $! readRational str
 985 tok_primdouble   str = ITprimdouble $! readRational str
 986
 987 -- -----------------------------------------------------------------------------
 988 -- Layout processing
 989
 990 -- we're at the first token on a line, insert layout tokens if necessary
 991 do_bol :: Action
 992 do_bol span _str _len = do
 993         pos <- getOffside
 994         case pos of
 995             LT -> do
 996                 --trace "layout: inserting '}'" $ do
 997                 popContext
 998                 -- do NOT pop the lex state, we might have a ';' to insert
 999                 return (L span ITvccurly)
1000             EQ -> do
1001                 --trace "layout: inserting ';'" $ do
1002                 popLexState
1003                 return (L span ITsemi)
1004             GT -> do
1005                 popLexState
1006                 lexToken
1007
1008 -- certain keywords put us in the "layout" state, where we might
1009 -- add an opening curly brace.
1010 maybe_layout ITdo       = pushLexState layout_do
1011 maybe_layout ITmdo      = pushLexState layout_do
1012 maybe_layout ITof       = pushLexState layout
1013 maybe_layout ITlet      = pushLexState layout
1014 maybe_layout ITwhere    = pushLexState layout
1015 maybe_layout ITrec      = pushLexState layout
1016 maybe_layout _          = return ()
1017
1018 -- Pushing a new implicit layout context.  If the indentation of the
1019 -- next token is not greater than the previous layout context, then
1020 -- Haskell 98 says that the new layout context should be empty; that is
1021 -- the lexer must generate {}.
1022 --
1023 -- We are slightly more lenient than this: when the new context is started
1024 -- by a 'do', then we allow the new context to be at the same indentation as
1025 -- the previous context.  This is what the 'strict' argument is for.
1026 --
1027 new_layout_context strict span _buf _len = do
1028     popLexState
1029     (AI _ offset _) <- getInput
1030     ctx <- getContext
1031     case ctx of
1032         Layout prev_off : _  |
1033            (strict     && prev_off >= offset  ||
1034             not strict && prev_off > offset) -> do
1035                 -- token is indented to the left of the previous context.
1036                 -- we must generate a {} sequence now.
1037                 pushLexState layout_left
1038                 return (L span ITvocurly)
1039         _ -> do
1040                 setContext (Layout offset : ctx)
1041                 return (L span ITvocurly)
1042
1043 do_layout_left span _buf _len = do
1044     popLexState
1045     pushLexState bol  -- we must be at the start of a line
1046     return (L span ITvccurly)
1047
1048 -- -----------------------------------------------------------------------------
1049 -- LINE pragmas
1050
1051 setLine :: Int -> Action
1052 setLine code span buf len = do
1053   let line = parseUnsignedInteger buf len 10 octDecDigit
1054   setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
1055         -- subtract one: the line number refers to the *following* line
1056   popLexState
1057   pushLexState code
1058   lexToken
1059
1060 setFile :: Int -> Action
1061 setFile code span buf len = do
1062   let file = lexemeToFastString (stepOn buf) (len-2)
1063   setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
1064   popLexState
1065   pushLexState code
1066   lexToken
1067
1068
1069 -- -----------------------------------------------------------------------------
1070 -- Options, includes and language pragmas.
1071
1072 lex_string_prag :: (String -> Token) -> Action
1073 lex_string_prag mkTok span _buf _len
1074     = do input <- getInput
1075          start <- getSrcLoc
1076          tok <- go [] input
1077          end <- getSrcLoc
1078          return (L (mkSrcSpan start end) tok)
1079     where go acc input
1080               = if isString input "#-}"
1081                    then do setInput input
1082                            return (mkTok (reverse acc))
1083                    else case alexGetChar input of
1084                           Just (c,i) -> go (c:acc) i
1085                           Nothing -> err input
1086           isString _ [] = True
1087           isString i (x:xs)
1088               = case alexGetChar i of
1089                   Just (c,i') | c == x    -> isString i' xs
1090                   _other -> False
1091           err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
1092
1093
1094 -- -----------------------------------------------------------------------------
1095 -- Strings & Chars
1096
1097 -- This stuff is horrible.  I hates it.
1098
1099 lex_string_tok :: Action
1100 lex_string_tok span _buf _len = do
1101   tok <- lex_string ""
1102   end <- getSrcLoc
1103   return (L (mkSrcSpan (srcSpanStart span) end) tok)
1104
1105 lex_string :: String -> P Token
1106 lex_string s = do
1107   i <- getInput
1108   case alexGetChar' i of
1109     Nothing -> lit_error
1110
1111     Just ('"',i)  -> do
1112         setInput i
1113         magicHash <- extension magicHashEnabled
1114         if magicHash
1115           then do
1116             i <- getInput
1117             case alexGetChar' i of
1118               Just ('#',i) -> do
1119                    setInput i
1120                    if any (> '\xFF') s
1121                     then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
1122                     else let s' = mkZFastString (reverse s) in
1123                          return (ITprimstring s')
1124                         -- mkZFastString is a hack to avoid encoding the
1125                         -- string in UTF-8.  We just want the exact bytes.
1126               _other ->
1127                 return (ITstring (mkFastString (reverse s)))
1128           else
1129                 return (ITstring (mkFastString (reverse s)))
1130
1131     Just ('\\',i)
1132         | Just ('&',i) <- next -> do
1133                 setInput i; lex_string s
1134         | Just (c,i) <- next, is_space c -> do
1135                 setInput i; lex_stringgap s
1136         where next = alexGetChar' i
1137
1138     Just (c, i) -> do
1139         c' <- lex_char c i
1140         lex_string (c':s)
1141
1142 lex_stringgap s = do
1143   c <- getCharOrFail
1144   case c of
1145     '\\' -> lex_string s
1146     c | is_space c -> lex_stringgap s
1147     _other -> lit_error
1148
1149
1150 lex_char_tok :: Action
1151 -- Here we are basically parsing character literals, such as 'x' or '\n'
1152 -- but, when Template Haskell is on, we additionally spot
1153 -- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
1154 -- but WIHTOUT CONSUMING the x or T part  (the parser does that).
1155 -- So we have to do two characters of lookahead: when we see 'x we need to
1156 -- see if there's a trailing quote
1157 lex_char_tok span _buf _len = do        -- We've seen '
1158    i1 <- getInput       -- Look ahead to first character
1159    let loc = srcSpanStart span
1160    case alexGetChar' i1 of
1161         Nothing -> lit_error
1162
1163         Just ('\'', i2@(AI end2 _ _)) -> do     -- We've seen ''
1164                   th_exts <- extension thEnabled
1165                   if th_exts then do
1166                         setInput i2
1167                         return (L (mkSrcSpan loc end2)  ITtyQuote)
1168                    else lit_error
1169
1170         Just ('\\', i2@(AI _end2 _ _)) -> do    -- We've seen 'backslash
1171                   setInput i2
1172                   lit_ch <- lex_escape
1173                   mc <- getCharOrFail   -- Trailing quote
1174                   if mc == '\'' then finish_char_tok loc lit_ch
1175                                 else do setInput i2; lit_error
1176
1177         Just (c, i2@(AI _end2 _ _))
1178                 | not (isAny c) -> lit_error
1179                 | otherwise ->
1180
1181                 -- We've seen 'x, where x is a valid character
1182                 --  (i.e. not newline etc) but not a quote or backslash
1183            case alexGetChar' i2 of      -- Look ahead one more character
1184                 Nothing -> lit_error
1185                 Just ('\'', i3) -> do   -- We've seen 'x'
1186                         setInput i3
1187                         finish_char_tok loc c
1188                 _other -> do            -- We've seen 'x not followed by quote
1189                                         -- If TH is on, just parse the quote only
1190                         th_exts <- extension thEnabled
1191                         let (AI end _ _) = i1
1192                         if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
1193                                    else do setInput i2; lit_error
1194
1195 finish_char_tok :: SrcLoc -> Char -> P (Located Token)
1196 finish_char_tok loc ch  -- We've already seen the closing quote
1197                         -- Just need to check for trailing #
1198   = do  magicHash <- extension magicHashEnabled
1199         i@(AI end _ _) <- getInput
1200         if magicHash then do
1201                 case alexGetChar' i of
1202                         Just ('#',i@(AI end _ _)) -> do
1203                                 setInput i
1204                                 return (L (mkSrcSpan loc end) (ITprimchar ch))
1205                         _other ->
1206                                 return (L (mkSrcSpan loc end) (ITchar ch))
1207                 else do
1208                    return (L (mkSrcSpan loc end) (ITchar ch))
1209
1210 lex_char :: Char -> AlexInput -> P Char
1211 lex_char c inp = do
1212   case c of
1213       '\\' -> do setInput inp; lex_escape
1214       c | isAny c -> do setInput inp; return c
1215       _other -> lit_error
1216
1217 isAny c | c > '\x7f' = isPrint c
1218         | otherwise  = is_any c
1219
1220 lex_escape :: P Char
1221 lex_escape = do
1222   c <- getCharOrFail
1223   case c of
1224         'a'   -> return '\a'
1225         'b'   -> return '\b'
1226         'f'   -> return '\f'
1227         'n'   -> return '\n'
1228         'r'   -> return '\r'
1229         't'   -> return '\t'
1230         'v'   -> return '\v'
1231         '\\'  -> return '\\'
1232         '"'   -> return '\"'
1233         '\''  -> return '\''
1234         '^'   -> do c <- getCharOrFail
1235                     if c >= '@' && c <= '_'
1236                         then return (chr (ord c - ord '@'))
1237                         else lit_error
1238
1239         'x'   -> readNum is_hexdigit 16 hexDigit
1240         'o'   -> readNum is_octdigit  8 octDecDigit
1241         x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)
1242
1243         c1 ->  do
1244            i <- getInput
1245            case alexGetChar' i of
1246             Nothing -> lit_error
1247             Just (c2,i2) ->
1248               case alexGetChar' i2 of
1249                 Nothing -> do setInput i2; lit_error
1250                 Just (c3,i3) ->
1251                    let str = [c1,c2,c3] in
1252                    case [ (c,rest) | (p,c) <- silly_escape_chars,
1253                                      Just rest <- [maybePrefixMatch p str] ] of
1254                           (escape_char,[]):_ -> do
1255                                 setInput i3
1256                                 return escape_char
1257                           (escape_char,_:_):_ -> do
1258                                 setInput i2
1259                                 return escape_char
1260                           [] -> lit_error
1261
1262 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char
1263 readNum is_digit base conv = do
1264   i <- getInput
1265   c <- getCharOrFail
1266   if is_digit c
1267         then readNum2 is_digit base conv (conv c)
1268         else do setInput i; lit_error
1269
1270 readNum2 is_digit base conv i = do
1271   input <- getInput
1272   read i input
1273   where read i input = do
1274           case alexGetChar' input of
1275             Just (c,input') | is_digit c -> do
1276                 read (i*base + conv c) input'
1277             _other -> do
1278                 if i >= 0 && i <= 0x10FFFF
1279                    then do setInput input; return (chr i)
1280                    else lit_error
1281
1282 silly_escape_chars = [
1283         ("NUL", '\NUL'),
1284         ("SOH", '\SOH'),
1285         ("STX", '\STX'),
1286         ("ETX", '\ETX'),
1287         ("EOT", '\EOT'),
1288         ("ENQ", '\ENQ'),
1289         ("ACK", '\ACK'),
1290         ("BEL", '\BEL'),
1291         ("BS", '\BS'),
1292         ("HT", '\HT'),
1293         ("LF", '\LF'),
1294         ("VT", '\VT'),
1295         ("FF", '\FF'),
1296         ("CR", '\CR'),
1297         ("SO", '\SO'),
1298         ("SI", '\SI'),
1299         ("DLE", '\DLE'),
1300         ("DC1", '\DC1'),
1301         ("DC2", '\DC2'),
1302         ("DC3", '\DC3'),
1303         ("DC4", '\DC4'),
1304         ("NAK", '\NAK'),
1305         ("SYN", '\SYN'),
1306         ("ETB", '\ETB'),
1307         ("CAN", '\CAN'),
1308         ("EM", '\EM'),
1309         ("SUB", '\SUB'),
1310         ("ESC", '\ESC'),
1311         ("FS", '\FS'),
1312         ("GS", '\GS'),
1313         ("RS", '\RS'),
1314         ("US", '\US'),
1315         ("SP", '\SP'),
1316         ("DEL", '\DEL')
1317         ]
1318
1319 -- before calling lit_error, ensure that the current input is pointing to
1320 -- the position of the error in the buffer.  This is so that we can report
1321 -- a correct location to the user, but also so we can detect UTF-8 decoding
1322 -- errors if they occur.
1323 lit_error = lexError "lexical error in string/character literal"
1324
1325 getCharOrFail :: P Char
1326 getCharOrFail =  do
1327   i <- getInput
1328   case alexGetChar' i of
1329         Nothing -> lexError "unexpected end-of-file in string/character literal"
1330         Just (c,i)  -> do setInput i; return c
1331
1332 -- -----------------------------------------------------------------------------
1333 -- QuasiQuote
1334
1335 lex_quasiquote_tok :: Action
1336 lex_quasiquote_tok span buf len = do
1337   let quoter = reverse $ takeWhile (/= '$')
1338                $ reverse $ lexemeToString buf (len - 1)
1339   quoteStart <- getSrcLoc
1340   quote <- lex_quasiquote ""
1341   end <- getSrcLoc
1342   return (L (mkSrcSpan (srcSpanStart span) end)
1343            (ITquasiQuote (mkFastString quoter,
1344                           mkFastString (reverse quote),
1345                           mkSrcSpan quoteStart end)))
1346
1347 lex_quasiquote :: String -> P String
1348 lex_quasiquote s = do
1349   i <- getInput
1350   case alexGetChar' i of
1351     Nothing -> lit_error
1352
1353     Just ('\\',i)
1354         | Just ('|',i) <- next -> do
1355                 setInput i; lex_quasiquote ('|' : s)
1356         | Just (']',i) <- next -> do
1357                 setInput i; lex_quasiquote (']' : s)
1358         where next = alexGetChar' i
1359
1360     Just ('|',i)
1361         | Just (']',i) <- next -> do
1362                 setInput i; return s
1363         where next = alexGetChar' i
1364
1365     Just (c, i) -> do
1366          setInput i; lex_quasiquote (c : s)
1367
1368 -- -----------------------------------------------------------------------------
1369 -- Warnings
1370
1371 warn :: DynFlag -> SDoc -> Action
1372 warn option warning srcspan _buf _len = do
1373     addWarning option srcspan warning
1374     lexToken
1375
1376 -- -----------------------------------------------------------------------------
1377 -- The Parse Monad
1378
1379 data LayoutContext
1380   = NoLayout
1381   | Layout !Int
1382   deriving Show
1383
1384 data ParseResult a
1385   = POk PState a
1386   | PFailed
1387         SrcSpan         -- The start and end of the text span related to
1388                         -- the error.  Might be used in environments which can
1389                         -- show this span, e.g. by highlighting it.
1390         Message         -- The error message
1391
1392 data PState = PState {
1393         buffer     :: StringBuffer,
1394     dflags     :: DynFlags,
1395     messages   :: Messages,
1396         last_loc   :: SrcSpan,  -- pos of previous token
1397         last_offs  :: !Int,     -- offset of the previous token from the
1398                                 -- beginning of  the current line.
1399                                 -- \t is equal to 8 spaces.
1400         last_len   :: !Int,     -- len of previous token
1401   last_line_len :: !Int,
1402         loc        :: SrcLoc,   -- current loc (end of prev token + 1)
1403         extsBitmap :: !Int,     -- bitmap that determines permitted extensions
1404         context    :: [LayoutContext],
1405         lex_state  :: [Int]
1406      }
1407         -- last_loc and last_len are used when generating error messages,
1408         -- and in pushCurrentContext only.  Sigh, if only Happy passed the
1409         -- current token to happyError, we could at least get rid of last_len.
1410         -- Getting rid of last_loc would require finding another way to
1411         -- implement pushCurrentContext (which is only called from one place).
1412
1413 newtype P a = P { unP :: PState -> ParseResult a }
1414
1415 instance Monad P where
1416   return = returnP
1417   (>>=) = thenP
1418   fail = failP
1419
1420 returnP :: a -> P a
1421 returnP a = a `seq` (P $ \s -> POk s a)
1422
1423 thenP :: P a -> (a -> P b) -> P b
1424 (P m) `thenP` k = P $ \ s ->
1425         case m s of
1426                 POk s1 a         -> (unP (k a)) s1
1427                 PFailed span err -> PFailed span err
1428
1429 failP :: String -> P a
1430 failP msg = P $ \s -> PFailed (last_loc s) (text msg)
1431
1432 failMsgP :: String -> P a
1433 failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
1434
1435 failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
1436 failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
1437
1438 failSpanMsgP :: SrcSpan -> SDoc -> P a
1439 failSpanMsgP span msg = P $ \_ -> PFailed span msg
1440
1441 extension :: (Int -> Bool) -> P Bool
1442 extension p = P $ \s -> POk s (p $! extsBitmap s)
1443
1444 getExts :: P Int
1445 getExts = P $ \s -> POk s (extsBitmap s)
1446
1447 setSrcLoc :: SrcLoc -> P ()
1448 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
1449
1450 getSrcLoc :: P SrcLoc
1451 getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
1452
1453 setLastToken :: SrcSpan -> Int -> Int -> P ()
1454 setLastToken loc len line_len = P $ \s -> POk s {
1455   last_loc=loc,
1456   last_len=len,
1457   last_line_len=line_len
1458 } ()
1459
1460 data AlexInput = AI SrcLoc {-#UNPACK#-}!Int StringBuffer
1461
1462 alexInputPrevChar :: AlexInput -> Char
1463 alexInputPrevChar (AI _ _ buf) = prevChar buf '\n'
1464
1465 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
1466 alexGetChar (AI loc ofs s)
1467   | atEnd s   = Nothing
1468   | otherwise = adj_c `seq` loc' `seq` ofs' `seq` s' `seq`
1469                 --trace (show (ord c)) $
1470                 Just (adj_c, (AI loc' ofs' s'))
1471   where (c,s') = nextChar s
1472         loc'   = advanceSrcLoc loc c
1473         ofs'   = advanceOffs c ofs
1474
1475         non_graphic     = '\x0'
1476         upper           = '\x1'
1477         lower           = '\x2'
1478         digit           = '\x3'
1479         symbol          = '\x4'
1480         space           = '\x5'
1481         other_graphic   = '\x6'
1482
1483         adj_c
1484           | c <= '\x06' = non_graphic
1485           | c <= '\x7f' = c
1486           -- Alex doesn't handle Unicode, so when Unicode
1487           -- character is encoutered we output these values
1488           -- with the actual character value hidden in the state.
1489           | otherwise =
1490                 case generalCategory c of
1491                   UppercaseLetter       -> upper
1492                   LowercaseLetter       -> lower
1493                   TitlecaseLetter       -> upper
1494                   ModifierLetter        -> other_graphic
1495                   OtherLetter           -> lower -- see #1103
1496                   NonSpacingMark        -> other_graphic
1497                   SpacingCombiningMark  -> other_graphic
1498                   EnclosingMark         -> other_graphic
1499                   DecimalNumber         -> digit
1500                   LetterNumber          -> other_graphic
1501                   OtherNumber           -> other_graphic
1502                   ConnectorPunctuation  -> other_graphic
1503                   DashPunctuation       -> other_graphic
1504                   OpenPunctuation       -> other_graphic
1505                   ClosePunctuation      -> other_graphic
1506                   InitialQuote          -> other_graphic
1507                   FinalQuote            -> other_graphic
1508                   OtherPunctuation      -> other_graphic
1509                   MathSymbol            -> symbol
1510                   CurrencySymbol        -> symbol
1511                   ModifierSymbol        -> symbol
1512                   OtherSymbol           -> symbol
1513                   Space                 -> space
1514                   _other                -> non_graphic
1515
1516 -- This version does not squash unicode characters, it is used when
1517 -- lexing strings.
1518 alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
1519 alexGetChar' (AI loc ofs s)
1520   | atEnd s   = Nothing
1521   | otherwise = c `seq` loc' `seq` ofs' `seq` s' `seq`
1522                 --trace (show (ord c)) $
1523                 Just (c, (AI loc' ofs' s'))
1524   where (c,s') = nextChar s
1525         loc'   = advanceSrcLoc loc c
1526         ofs'   = advanceOffs c ofs
1527
1528 advanceOffs :: Char -> Int -> Int
1529 advanceOffs '\n' _    = 0
1530 advanceOffs '\t' offs = (offs `quot` 8 + 1) * 8
1531 advanceOffs _    offs = offs + 1
1532
1533 getInput :: P AlexInput
1534 getInput = P $ \s@PState{ loc=l, last_offs=o, buffer=b } -> POk s (AI l o b)
1535
1536 setInput :: AlexInput -> P ()
1537 setInput (AI l o b) = P $ \s -> POk s{ loc=l, last_offs=o, buffer=b } ()
1538
1539 pushLexState :: Int -> P ()
1540 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
1541
1542 popLexState :: P Int
1543 popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
1544
1545 getLexState :: P Int
1546 getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
1547
1548 -- for reasons of efficiency, flags indicating language extensions (eg,
1549 -- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed
1550 -- integer
1551
1552 genericsBit, ffiBit, parrBit :: Int
1553 genericsBit = 0 -- {| and |}
1554 ffiBit     = 1
1555 parrBit    = 2
1556 arrowsBit  = 4
1557 thBit      = 5
1558 ipBit      = 6
1559 explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
1560 bangPatBit = 8  -- Tells the parser to understand bang-patterns
1561                 -- (doesn't affect the lexer)
1562 tyFamBit   = 9  -- indexed type families: 'family' keyword and kind sigs
1563 haddockBit = 10 -- Lex and parse Haddock comments
1564 magicHashBit = 11 -- # in both functions and operators
1565 kindSigsBit = 12 -- Kind signatures on type variables
1566 recursiveDoBit = 13 -- mdo
1567 unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
1568 unboxedTuplesBit = 15 -- (# and #)
1569 standaloneDerivingBit = 16 -- standalone instance deriving declarations
1570 transformComprehensionsBit = 17
1571 qqBit      = 18 -- enable quasiquoting
1572
1573 genericsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
1574 always           _     = True
1575 genericsEnabled  flags = testBit flags genericsBit
1576 ffiEnabled       flags = testBit flags ffiBit
1577 parrEnabled      flags = testBit flags parrBit
1578 arrowsEnabled    flags = testBit flags arrowsBit
1579 thEnabled        flags = testBit flags thBit
1580 ipEnabled        flags = testBit flags ipBit
1581 explicitForallEnabled flags = testBit flags explicitForallBit
1582 bangPatEnabled   flags = testBit flags bangPatBit
1583 tyFamEnabled     flags = testBit flags tyFamBit
1584 haddockEnabled   flags = testBit flags haddockBit
1585 magicHashEnabled flags = testBit flags magicHashBit
1586 kindSigsEnabled  flags = testBit flags kindSigsBit
1587 recursiveDoEnabled flags = testBit flags recursiveDoBit
1588 unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
1589 unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
1590 standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit
1591 transformComprehensionsEnabled flags = testBit flags transformComprehensionsBit
1592 qqEnabled        flags = testBit flags qqBit
1593
1594 -- PState for parsing options pragmas
1595 --
1596 pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
1597 pragState dynflags buf loc =
1598   PState {
1599       buffer        = buf,
1600       messages      = emptyMessages,
1601       dflags        = dynflags,
1602       last_loc      = mkSrcSpan loc loc,
1603       last_offs     = 0,
1604       last_len      = 0,
1605       last_line_len = 0,
1606       loc           = loc,
1607       extsBitmap    = 0,
1608       context       = [],
1609       lex_state     = [bol, option_prags, 0]
1610     }
1611
1612
1613 -- create a parse state
1614 --
1615 mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
1616 mkPState buf loc flags  =
1617   PState {
1618       buffer          = buf,
1619       dflags        = flags,
1620       messages      = emptyMessages,
1621       last_loc      = mkSrcSpan loc loc,
1622       last_offs     = 0,
1623       last_len      = 0,
1624       last_line_len = 0,
1625       loc           = loc,
1626       extsBitmap    = fromIntegral bitmap,
1627       context       = [],
1628       lex_state     = [bol, 0]
1629         -- we begin in the layout state if toplev_layout is set
1630     }
1631     where
1632       bitmap = genericsBit `setBitIf` dopt Opt_Generics flags
1633                .|. ffiBit       `setBitIf` dopt Opt_ForeignFunctionInterface flags
1634                .|. parrBit      `setBitIf` dopt Opt_PArr         flags
1635                .|. arrowsBit    `setBitIf` dopt Opt_Arrows       flags
1636                .|. thBit        `setBitIf` dopt Opt_TemplateHaskell flags
1637                .|. qqBit        `setBitIf` dopt Opt_QuasiQuotes flags
1638                .|. ipBit        `setBitIf` dopt Opt_ImplicitParams flags
1639                .|. explicitForallBit `setBitIf` dopt Opt_ScopedTypeVariables flags
1640                .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
1641                .|. explicitForallBit `setBitIf` dopt Opt_ExistentialQuantification flags
1642                .|. explicitForallBit `setBitIf` dopt Opt_Rank2Types flags
1643                .|. explicitForallBit `setBitIf` dopt Opt_RankNTypes flags
1644                .|. bangPatBit   `setBitIf` dopt Opt_BangPatterns flags
1645                .|. tyFamBit     `setBitIf` dopt Opt_TypeFamilies flags
1646                .|. haddockBit   `setBitIf` dopt Opt_Haddock      flags
1647                .|. magicHashBit `setBitIf` dopt Opt_MagicHash    flags
1648                .|. kindSigsBit  `setBitIf` dopt Opt_KindSignatures flags
1649                .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
1650                .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
1651                .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
1652                .|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags
1653            .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags
1654       --
1655       setBitIf :: Int -> Bool -> Int
1656       b `setBitIf` cond | cond      = bit b
1657                         | otherwise = 0
1658
1659 addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
1660 addWarning option srcspan warning
1661  = P $ \s@PState{messages=(ws,es), dflags=d} ->
1662        let warning' = mkWarnMsg srcspan alwaysQualify warning
1663            ws' = if dopt option d then ws `snocBag` warning' else ws
1664        in POk s{messages=(ws', es)} ()
1665
1666 getMessages :: PState -> Messages
1667 getMessages PState{messages=ms} = ms
1668
1669 getContext :: P [LayoutContext]
1670 getContext = P $ \s@PState{context=ctx} -> POk s ctx
1671
1672 setContext :: [LayoutContext] -> P ()
1673 setContext ctx = P $ \s -> POk s{context=ctx} ()
1674
1675 popContext :: P ()
1676 popContext = P $ \ s@(PState{ buffer = buf, context = ctx,
1677                               last_len = len, last_loc = last_loc }) ->
1678   case ctx of
1679         (_:tl) -> POk s{ context = tl } ()
1680         []     -> PFailed last_loc (srcParseErr buf len)
1681
1682 -- Push a new layout context at the indentation of the last token read.
1683 -- This is only used at the outer level of a module when the 'module'
1684 -- keyword is missing.
1685 pushCurrentContext :: P ()
1686 pushCurrentContext = P $ \ s@PState{ last_offs=offs, last_line_len=len, context=ctx } ->
1687     POk s{context = Layout (offs-len) : ctx} ()
1688 --trace ("off: " ++ show offs ++ ", len: " ++ show len) $ POk s{context = Layout (offs-len) : ctx} ()
1689
1690 getOffside :: P Ordering
1691 getOffside = P $ \s@PState{last_offs=offs, context=stk} ->
1692                 let ord = case stk of
1693                         (Layout n:_) -> compare offs n
1694                         _            -> GT
1695                 in POk s ord
1696
1697 -- ---------------------------------------------------------------------------
1698 -- Construct a parse error
1699
1700 srcParseErr
1701   :: StringBuffer       -- current buffer (placed just after the last token)
1702   -> Int                -- length of the previous token
1703   -> Message
1704 srcParseErr buf len
1705   = hcat [ if null token
1706              then ptext (sLit "parse error (possibly incorrect indentation)")
1707              else hcat [ptext (sLit "parse error on input "),
1708                         char '`', text token, char '\'']
1709     ]
1710   where token = lexemeToString (offsetBytes (-len) buf) len
1711
1712 -- Report a parse failure, giving the span of the previous token as
1713 -- the location of the error.  This is the entry point for errors
1714 -- detected during parsing.
1715 srcParseFail :: P a
1716 srcParseFail = P $ \PState{ buffer = buf, last_len = len,
1717                             last_loc = last_loc } ->
1718     PFailed last_loc (srcParseErr buf len)
1719
1720 -- A lexical error is reported at a particular position in the source file,
1721 -- not over a token range.
1722 lexError :: String -> P a
1723 lexError str = do
1724   loc <- getSrcLoc
1725   (AI end _ buf) <- getInput
1726   reportLexError loc end buf str
1727
1728 -- -----------------------------------------------------------------------------
1729 -- This is the top-level function: called from the parser each time a
1730 -- new token is to be read from the input.
1731
1732 lexer :: (Located Token -> P a) -> P a
1733 lexer cont = do
1734   tok@(L _span _tok__) <- lexToken
1735 --  trace ("token: " ++ show tok__) $ do
1736   cont tok
1737
1738 lexToken :: P (Located Token)
1739 lexToken = do
1740   inp@(AI loc1 _ buf) <- getInput
1741   sc <- getLexState
1742   exts <- getExts
1743   case alexScanUser exts inp sc of
1744     AlexEOF -> do
1745         let span = mkSrcSpan loc1 loc1
1746         setLastToken span 0 0
1747         return (L span ITeof)
1748     AlexError (AI loc2 _ buf) ->
1749         reportLexError loc1 loc2 buf "lexical error"
1750     AlexSkip inp2 _ -> do
1751         setInput inp2
1752         lexToken
1753     AlexToken inp2@(AI end _ buf2) _ t -> do
1754         setInput inp2
1755         let span = mkSrcSpan loc1 end
1756         let bytes = byteDiff buf buf2
1757         span `seq` setLastToken span bytes bytes
1758         t span buf bytes
1759
1760 reportLexError loc1 loc2 buf str
1761   | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
1762   | otherwise =
1763   let
1764         c = fst (nextChar buf)
1765   in
1766   if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
1767     then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
1768     else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
1769 }