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