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