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