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* (WARNING|warning)
 252                                         { token ITwarning_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   | ITwarning_prag
 472   | ITdeprecated_prag
 473   | ITline_prag
 474   | ITscc_prag
 475   | ITgenerated_prag
 476   | ITcore_prag                 -- hdaume: core annotations
 477   | ITunpack_prag
 478   | ITclose_prag
 479   | IToptions_prag String
 480   | ITinclude_prag String
 481   | ITlanguage_prag
 482
 483   | ITdotdot                    -- reserved symbols
 484   | ITcolon
 485   | ITdcolon
 486   | ITequal
 487   | ITlam
 488   | ITvbar
 489   | ITlarrow
 490   | ITrarrow
 491   | ITat
 492   | ITtilde
 493   | ITdarrow
 494   | ITminus
 495   | ITbang
 496   | ITstar
 497   | ITdot
 498
 499   | ITbiglam                    -- GHC-extension symbols
 500
 501   | ITocurly                    -- special symbols
 502   | ITccurly
 503   | ITocurlybar                 -- {|, for type applications
 504   | ITccurlybar                 -- |}, for type applications
 505   | ITvocurly
 506   | ITvccurly
 507   | ITobrack
 508   | ITopabrack                  -- [:, for parallel arrays with -XParr
 509   | ITcpabrack                  -- :], for parallel arrays with -XParr
 510   | ITcbrack
 511   | IToparen
 512   | ITcparen
 513   | IToubxparen
 514   | ITcubxparen
 515   | ITsemi
 516   | ITcomma
 517   | ITunderscore
 518   | ITbackquote
 519
 520   | ITvarid   FastString        -- identifiers
 521   | ITconid   FastString
 522   | ITvarsym  FastString
 523   | ITconsym  FastString
 524   | ITqvarid  (FastString,FastString)
 525   | ITqconid  (FastString,FastString)
 526   | ITqvarsym (FastString,FastString)
 527   | ITqconsym (FastString,FastString)
 528
 529   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
 530
 531   | ITpragma StringBuffer
 532
 533   | ITchar       Char
 534   | ITstring     FastString
 535   | ITinteger    Integer
 536   | ITrational   Rational
 537
 538   | ITprimchar   Char
 539   | ITprimstring FastString
 540   | ITprimint    Integer
 541   | ITprimword   Integer
 542   | ITprimfloat  Rational
 543   | ITprimdouble Rational
 544
 545   -- MetaHaskell extension tokens
 546   | ITopenExpQuote              --  [| or [e|
 547   | ITopenPatQuote              --  [p|
 548   | ITopenDecQuote              --  [d|
 549   | ITopenTypQuote              --  [t|
 550   | ITcloseQuote                --  |]
 551   | ITidEscape   FastString     --  $x
 552   | ITparenEscape               --  $(
 553   | ITvarQuote                  --  '
 554   | ITtyQuote                   --  ''
 555   | ITquasiQuote (FastString,FastString,SrcSpan) --  [:...|...|]
 556
 557   -- Arrow notation extension
 558   | ITproc
 559   | ITrec
 560   | IToparenbar                 --  (|
 561   | ITcparenbar                 --  |)
 562   | ITlarrowtail                --  -<
 563   | ITrarrowtail                --  >-
 564   | ITLarrowtail                --  -<<
 565   | ITRarrowtail                --  >>-
 566
 567   | ITunknown String            -- Used when the lexer can't make sense of it
 568   | ITeof                       -- end of file token
 569
 570   -- Documentation annotations
 571   | ITdocCommentNext  String     -- something beginning '-- |'
 572   | ITdocCommentPrev  String     -- something beginning '-- ^'
 573   | ITdocCommentNamed String     -- something beginning '-- $'
 574   | ITdocSection      Int String -- a section heading
 575   | ITdocOptions      String     -- doc options (prune, ignore-exports, etc)
 576   | ITdocOptionsOld   String     -- doc options declared "-- # ..."-style
 577
 578 #ifdef DEBUG
 579   deriving Show -- debugging
 580 #endif
 581
 582 {-
 583 isSpecial :: Token -> Bool
 584 -- If we see M.x, where x is a keyword, but
 585 -- is special, we treat is as just plain M.x,
 586 -- not as a keyword.
 587 isSpecial ITas          = True
 588 isSpecial IThiding      = True
 589 isSpecial ITqualified   = True
 590 isSpecial ITforall      = True
 591 isSpecial ITexport      = True
 592 isSpecial ITlabel       = True
 593 isSpecial ITdynamic     = True
 594 isSpecial ITsafe        = True
 595 isSpecial ITthreadsafe  = True
 596 isSpecial ITunsafe      = True
 597 isSpecial ITccallconv   = True
 598 isSpecial ITstdcallconv = True
 599 isSpecial ITmdo         = True
 600 isSpecial ITfamily      = True
 601 isSpecial ITgroup   = True
 602 isSpecial ITby      = True
 603 isSpecial ITusing   = True
 604 isSpecial _             = False
 605 -}
 606
 607 -- the bitmap provided as the third component indicates whether the
 608 -- corresponding extension keyword is valid under the extension options
 609 -- provided to the compiler; if the extension corresponding to *any* of the
 610 -- bits set in the bitmap is enabled, the keyword is valid (this setup
 611 -- facilitates using a keyword in two different extensions that can be
 612 -- activated independently)
 613 --
 614 reservedWordsFM = listToUFM $
 615         map (\(x, y, z) -> (mkFastString x, (y, z)))
 616        [( "_",          ITunderscore,   0 ),
 617         ( "as",         ITas,           0 ),
 618         ( "case",       ITcase,         0 ),
 619         ( "class",      ITclass,        0 ),
 620         ( "data",       ITdata,         0 ),
 621         ( "default",    ITdefault,      0 ),
 622         ( "deriving",   ITderiving,     0 ),
 623         ( "do",         ITdo,           0 ),
 624         ( "else",       ITelse,         0 ),
 625         ( "hiding",     IThiding,       0 ),
 626         ( "if",         ITif,           0 ),
 627         ( "import",     ITimport,       0 ),
 628         ( "in",         ITin,           0 ),
 629         ( "infix",      ITinfix,        0 ),
 630         ( "infixl",     ITinfixl,       0 ),
 631         ( "infixr",     ITinfixr,       0 ),
 632         ( "instance",   ITinstance,     0 ),
 633         ( "let",        ITlet,          0 ),
 634         ( "module",     ITmodule,       0 ),
 635         ( "newtype",    ITnewtype,      0 ),
 636         ( "of",         ITof,           0 ),
 637         ( "qualified",  ITqualified,    0 ),
 638         ( "then",       ITthen,         0 ),
 639         ( "type",       ITtype,         0 ),
 640         ( "where",      ITwhere,        0 ),
 641         ( "_scc_",      ITscc,          0 ),            -- ToDo: remove
 642
 643     ( "forall", ITforall,        bit explicitForallBit),
 644         ( "mdo",        ITmdo,           bit recursiveDoBit),
 645         ( "family",     ITfamily,        bit tyFamBit),
 646     ( "group",  ITgroup,     bit transformComprehensionsBit),
 647     ( "by",     ITby,        bit transformComprehensionsBit),
 648     ( "using",  ITusing,     bit transformComprehensionsBit),
 649
 650         ( "foreign",    ITforeign,       bit ffiBit),
 651         ( "export",     ITexport,        bit ffiBit),
 652         ( "label",      ITlabel,         bit ffiBit),
 653         ( "dynamic",    ITdynamic,       bit ffiBit),
 654         ( "safe",       ITsafe,          bit ffiBit),
 655         ( "threadsafe", ITthreadsafe,    bit ffiBit),
 656         ( "unsafe",     ITunsafe,        bit ffiBit),
 657         ( "stdcall",    ITstdcallconv,   bit ffiBit),
 658         ( "ccall",      ITccallconv,     bit ffiBit),
 659         ( "dotnet",     ITdotnet,        bit ffiBit),
 660
 661         ( "rec",        ITrec,           bit arrowsBit),
 662         ( "proc",       ITproc,          bit arrowsBit)
 663      ]
 664
 665 reservedSymsFM :: UniqFM (Token, Int -> Bool)
 666 reservedSymsFM = listToUFM $
 667     map (\ (x,y,z) -> (mkFastString x,(y,z)))
 668       [ ("..",  ITdotdot,   always)
 669         -- (:) is a reserved op, meaning only list cons
 670        ,(":",   ITcolon,    always)
 671        ,("::",  ITdcolon,   always)
 672        ,("=",   ITequal,    always)
 673        ,("\\",  ITlam,      always)
 674        ,("|",   ITvbar,     always)
 675        ,("<-",  ITlarrow,   always)
 676        ,("->",  ITrarrow,   always)
 677        ,("@",   ITat,       always)
 678        ,("~",   ITtilde,    always)
 679        ,("=>",  ITdarrow,   always)
 680        ,("-",   ITminus,    always)
 681        ,("!",   ITbang,     always)
 682
 683         -- For data T (a::*) = MkT
 684        ,("*", ITstar, \i -> kindSigsEnabled i || tyFamEnabled i)
 685         -- For 'forall a . t'
 686        ,(".", ITdot, explicitForallEnabled)
 687
 688        ,("-<",  ITlarrowtail, arrowsEnabled)
 689        ,(">-",  ITrarrowtail, arrowsEnabled)
 690        ,("-<<", ITLarrowtail, arrowsEnabled)
 691        ,(">>-", ITRarrowtail, arrowsEnabled)
 692
 693 #if __GLASGOW_HASKELL__ >= 605
 694        ,("∷",   ITdcolon, unicodeSyntaxEnabled)
 695        ,("⇒",   ITdarrow, unicodeSyntaxEnabled)
 696        ,("∀",   ITforall, \i -> unicodeSyntaxEnabled i &&
 697                                 explicitForallEnabled i)
 698        ,("→",   ITrarrow, unicodeSyntaxEnabled)
 699        ,("←",   ITlarrow, unicodeSyntaxEnabled)
 700        ,("⋯",   ITdotdot, unicodeSyntaxEnabled)
 701         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
 702         -- form part of a large operator.  This would let us have a better
 703         -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
 704 #endif
 705        ]
 706
 707 -- -----------------------------------------------------------------------------
 708 -- Lexer actions
 709
 710 type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
 711
 712 special :: Token -> Action
 713 special tok span _buf _len = return (L span tok)
 714
 715 token, layout_token :: Token -> Action
 716 token t span _buf _len = return (L span t)
 717 layout_token t span _buf _len = pushLexState layout >> return (L span t)
 718
 719 idtoken :: (StringBuffer -> Int -> Token) -> Action
 720 idtoken f span buf len = return (L span $! (f buf len))
 721
 722 skip_one_varid :: (FastString -> Token) -> Action
 723 skip_one_varid f span buf len
 724   = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
 725
 726 strtoken :: (String -> Token) -> Action
 727 strtoken f span buf len =
 728   return (L span $! (f $! lexemeToString buf len))
 729
 730 init_strtoken :: Int -> (String -> Token) -> Action
 731 -- like strtoken, but drops the last N character(s)
 732 init_strtoken drop f span buf len =
 733   return (L span $! (f $! lexemeToString buf (len-drop)))
 734
 735 begin :: Int -> Action
 736 begin code _span _str _len = do pushLexState code; lexToken
 737
 738 pop :: Action
 739 pop _span _buf _len = do popLexState; lexToken
 740
 741 pop_and :: Action -> Action
 742 pop_and act span buf len = do popLexState; act span buf len
 743
 744 {-# INLINE nextCharIs #-}
 745 nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
 746
 747 notFollowedBy char _ _ _ (AI _ _ buf)
 748   = nextCharIs buf (/=char)
 749
 750 notFollowedBySymbol _ _ _ (AI _ _ buf)
 751   = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
 752
 753 -- We must reject doc comments as being ordinary comments everywhere.
 754 -- In some cases the doc comment will be selected as the lexeme due to
 755 -- maximal munch, but not always, because the nested comment rule is
 756 -- valid in all states, but the doc-comment rules are only valid in
 757 -- the non-layout states.
 758 isNormalComment bits _ _ (AI _ _ buf)
 759   | haddockEnabled bits = notFollowedByDocOrPragma
 760   | otherwise           = nextCharIs buf (/='#')
 761   where
 762     notFollowedByDocOrPragma
 763        = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
 764
 765 spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
 766
 767 {-
 768 haddockDisabledAnd p bits _ _ (AI _ _ buf)
 769   = if haddockEnabled bits then False else (p buf)
 770 -}
 771
 772 atEOL _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf == '\n'
 773
 774 ifExtension pred bits _ _ _ = pred bits
 775
 776 multiline_doc_comment :: Action
 777 multiline_doc_comment span buf _len = withLexedDocType (worker "")
 778   where
 779     worker commentAcc input docType oneLine = case alexGetChar input of
 780       Just ('\n', input')
 781         | oneLine -> docCommentEnd input commentAcc docType buf span
 782         | otherwise -> case checkIfCommentLine input' of
 783           Just input -> worker ('\n':commentAcc) input docType False
 784           Nothing -> docCommentEnd input commentAcc docType buf span
 785       Just (c, input) -> worker (c:commentAcc) input docType oneLine
 786       Nothing -> docCommentEnd input commentAcc docType buf span
 787
 788     checkIfCommentLine input = check (dropNonNewlineSpace input)
 789       where
 790         check input = case alexGetChar input of
 791           Just ('-', input) -> case alexGetChar input of
 792             Just ('-', input) -> case alexGetChar input of
 793               Just (c, _) | c /= '-' -> Just input
 794               _ -> Nothing
 795             _ -> Nothing
 796           _ -> Nothing
 797
 798         dropNonNewlineSpace input = case alexGetChar input of
 799           Just (c, input')
 800             | isSpace c && c /= '\n' -> dropNonNewlineSpace input'
 801             | otherwise -> input
 802           Nothing -> input
 803
 804 {-
 805   nested comments require traversing by hand, they can't be parsed
 806   using regular expressions.
 807 -}
 808 nested_comment :: P (Located Token) -> Action
 809 nested_comment cont span _str _len = do
 810   input <- getInput
 811   go (1::Int) input
 812   where
 813     go 0 input = do setInput input; cont
 814     go n input = case alexGetChar input of
 815       Nothing -> errBrace input span
 816       Just ('-',input) -> case alexGetChar input of
 817         Nothing  -> errBrace input span
 818         Just ('\125',input) -> go (n-1) input
 819         Just (_,_)          -> go n input
 820       Just ('\123',input) -> case alexGetChar input of
 821         Nothing  -> errBrace input span
 822         Just ('-',input) -> go (n+1) input
 823         Just (_,_)       -> go n input
 824       Just (_,input) -> go n input
 825
 826 nested_doc_comment :: Action
 827 nested_doc_comment span buf _len = withLexedDocType (go "")
 828   where
 829     go commentAcc input docType _ = case alexGetChar input of
 830       Nothing -> errBrace input span
 831       Just ('-',input) -> case alexGetChar input of
 832         Nothing -> errBrace input span
 833         Just ('\125',input) ->
 834           docCommentEnd input commentAcc docType buf span
 835         Just (_,_) -> go ('-':commentAcc) input docType False
 836       Just ('\123', input) -> case alexGetChar input of
 837         Nothing  -> errBrace input span
 838         Just ('-',input) -> do
 839           setInput input
 840           let cont = do input <- getInput; go commentAcc input docType False
 841           nested_comment cont span buf _len
 842         Just (_,_) -> go ('\123':commentAcc) input docType False
 843       Just (c,input) -> go (c:commentAcc) input docType False
 844
 845 withLexedDocType lexDocComment = do
 846   input@(AI _ _ buf) <- getInput
 847   case prevChar buf ' ' of
 848     '|' -> lexDocComment input ITdocCommentNext False
 849     '^' -> lexDocComment input ITdocCommentPrev False
 850     '$' -> lexDocComment input ITdocCommentNamed False
 851     '*' -> lexDocSection 1 input
 852     '#' -> lexDocComment input ITdocOptionsOld False
 853  where
 854     lexDocSection n input = case alexGetChar input of
 855       Just ('*', input) -> lexDocSection (n+1) input
 856       Just (_,   _)     -> lexDocComment input (ITdocSection n) True
 857       Nothing -> do setInput input; lexToken -- eof reached, lex it normally
 858
 859 -- docCommentEnd
 860 -------------------------------------------------------------------------------
 861 -- This function is quite tricky. We can't just return a new token, we also
 862 -- need to update the state of the parser. Why? Because the token is longer
 863 -- than what was lexed by Alex, and the lexToken function doesn't know this, so
 864 -- it writes the wrong token length to the parser state. This function is
 865 -- called afterwards, so it can just update the state.
 866
 867 -- This is complicated by the fact that Haddock tokens can span multiple lines,
 868 -- which is something that the original lexer didn't account for.
 869 -- I have added last_line_len in the parser state which represents the length
 870 -- of the part of the token that is on the last line. It is now used for layout
 871 -- calculation in pushCurrentContext instead of last_len. last_len is, like it
 872 -- was before, the full length of the token, and it is now only used for error
 873 -- messages. /Waern
 874
 875 docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
 876                  SrcSpan -> P (Located Token)
 877 docCommentEnd input commentAcc docType buf span = do
 878   setInput input
 879   let (AI loc last_offs nextBuf) = input
 880       comment = reverse commentAcc
 881       span' = mkSrcSpan (srcSpanStart span) loc
 882       last_len = byteDiff buf nextBuf
 883
 884       last_line_len = if (last_offs - last_len < 0)
 885         then last_offs
 886         else last_len
 887
 888   span `seq` setLastToken span' last_len last_line_len
 889   return (L span' (docType comment))
 890
 891 errBrace (AI end _ _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
 892
 893 open_brace, close_brace :: Action
 894 open_brace span _str _len = do
 895   ctx <- getContext
 896   setContext (NoLayout:ctx)
 897   return (L span ITocurly)
 898 close_brace span _str _len = do
 899   popContext
 900   return (L span ITccurly)
 901
 902 qvarid buf len = ITqvarid $! splitQualName buf len
 903 qconid buf len = ITqconid $! splitQualName buf len
 904
 905 splitQualName :: StringBuffer -> Int -> (FastString,FastString)
 906 -- takes a StringBuffer and a length, and returns the module name
 907 -- and identifier parts of a qualified name.  Splits at the *last* dot,
 908 -- because of hierarchical module names.
 909 splitQualName orig_buf len = split orig_buf orig_buf
 910   where
 911     split buf dot_buf
 912         | orig_buf `byteDiff` buf >= len  = done dot_buf
 913         | c == '.'                        = found_dot buf'
 914         | otherwise                       = split buf' dot_buf
 915       where
 916        (c,buf') = nextChar buf
 917
 918     -- careful, we might get names like M....
 919     -- so, if the character after the dot is not upper-case, this is
 920     -- the end of the qualifier part.
 921     found_dot buf -- buf points after the '.'
 922         | isUpper c    = split buf' buf
 923         | otherwise    = done buf
 924       where
 925        (c,buf') = nextChar buf
 926
 927     done dot_buf =
 928         (lexemeToFastString orig_buf (qual_size - 1),
 929          lexemeToFastString dot_buf (len - qual_size))
 930       where
 931         qual_size = orig_buf `byteDiff` dot_buf
 932
 933 varid span buf len =
 934   fs `seq`
 935   case lookupUFM reservedWordsFM fs of
 936         Just (keyword,0)    -> do
 937                 maybe_layout keyword
 938                 return (L span keyword)
 939         Just (keyword,exts) -> do
 940                 b <- extension (\i -> exts .&. i /= 0)
 941                 if b then do maybe_layout keyword
 942                              return (L span keyword)
 943                      else return (L span (ITvarid fs))
 944         _other -> return (L span (ITvarid fs))
 945   where
 946         fs = lexemeToFastString buf len
 947
 948 conid buf len = ITconid fs
 949   where fs = lexemeToFastString buf len
 950
 951 qvarsym buf len = ITqvarsym $! splitQualName buf len
 952 qconsym buf len = ITqconsym $! splitQualName buf len
 953
 954 varsym = sym ITvarsym
 955 consym = sym ITconsym
 956
 957 sym con span buf len =
 958   case lookupUFM reservedSymsFM fs of
 959         Just (keyword,exts) -> do
 960                 b <- extension exts
 961                 if b then return (L span keyword)
 962                      else return (L span $! con fs)
 963         _other -> return (L span $! con fs)
 964   where
 965         fs = lexemeToFastString buf len
 966
 967 -- Variations on the integral numeric literal.
 968 tok_integral :: (Integer -> Token)
 969      -> (Integer -> Integer)
 970  --    -> (StringBuffer -> StringBuffer) -> (Int -> Int)
 971      -> Int -> Int
 972      -> (Integer, (Char->Int)) -> Action
 973 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len =
 974   return $ L span $ itint $! transint $ parseUnsignedInteger
 975      (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
 976
 977 -- some conveniences for use with tok_integral
 978 tok_num = tok_integral ITinteger
 979 tok_primint = tok_integral ITprimint
 980 tok_primword = tok_integral ITprimword positive
 981 positive = id
 982 negative = negate
 983 decimal = (10,octDecDigit)
 984 octal = (8,octDecDigit)
 985 hexadecimal = (16,hexDigit)
 986
 987 -- readRational can understand negative rationals, exponents, everything.
 988 tok_float        str = ITrational   $! readRational str
 989 tok_primfloat    str = ITprimfloat  $! readRational str
 990 tok_primdouble   str = ITprimdouble $! readRational str
 991
 992 -- -----------------------------------------------------------------------------
 993 -- Layout processing
 994
 995 -- we're at the first token on a line, insert layout tokens if necessary
 996 do_bol :: Action
 997 do_bol span _str _len = do
 998         pos <- getOffside
 999         case pos of
1000             LT -> do
1001                 --trace "layout: inserting '}'" $ do
1002                 popContext
1003                 -- do NOT pop the lex state, we might have a ';' to insert
1004                 return (L span ITvccurly)
1005             EQ -> do
1006                 --trace "layout: inserting ';'" $ do
1007                 popLexState
1008                 return (L span ITsemi)
1009             GT -> do
1010                 popLexState
1011                 lexToken
1012
1013 -- certain keywords put us in the "layout" state, where we might
1014 -- add an opening curly brace.
1015 maybe_layout ITdo       = pushLexState layout_do
1016 maybe_layout ITmdo      = pushLexState layout_do
1017 maybe_layout ITof       = pushLexState layout
1018 maybe_layout ITlet      = pushLexState layout
1019 maybe_layout ITwhere    = pushLexState layout
1020 maybe_layout ITrec      = pushLexState layout
1021 maybe_layout _          = return ()
1022
1023 -- Pushing a new implicit layout context.  If the indentation of the
1024 -- next token is not greater than the previous layout context, then
1025 -- Haskell 98 says that the new layout context should be empty; that is
1026 -- the lexer must generate {}.
1027 --
1028 -- We are slightly more lenient than this: when the new context is started
1029 -- by a 'do', then we allow the new context to be at the same indentation as
1030 -- the previous context.  This is what the 'strict' argument is for.
1031 --
1032 new_layout_context strict span _buf _len = do
1033     popLexState
1034     (AI _ offset _) <- getInput
1035     ctx <- getContext
1036     case ctx of
1037         Layout prev_off : _  |
1038            (strict     && prev_off >= offset  ||
1039             not strict && prev_off > offset) -> do
1040                 -- token is indented to the left of the previous context.
1041                 -- we must generate a {} sequence now.
1042                 pushLexState layout_left
1043                 return (L span ITvocurly)
1044         _ -> do
1045                 setContext (Layout offset : ctx)
1046                 return (L span ITvocurly)
1047
1048 do_layout_left span _buf _len = do
1049     popLexState
1050     pushLexState bol  -- we must be at the start of a line
1051     return (L span ITvccurly)
1052
1053 -- -----------------------------------------------------------------------------
1054 -- LINE pragmas
1055
1056 setLine :: Int -> Action
1057 setLine code span buf len = do
1058   let line = parseUnsignedInteger buf len 10 octDecDigit
1059   setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
1060         -- subtract one: the line number refers to the *following* line
1061   popLexState
1062   pushLexState code
1063   lexToken
1064
1065 setFile :: Int -> Action
1066 setFile code span buf len = do
1067   let file = lexemeToFastString (stepOn buf) (len-2)
1068   setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
1069   popLexState
1070   pushLexState code
1071   lexToken
1072
1073
1074 -- -----------------------------------------------------------------------------
1075 -- Options, includes and language pragmas.
1076
1077 lex_string_prag :: (String -> Token) -> Action
1078 lex_string_prag mkTok span _buf _len
1079     = do input <- getInput
1080          start <- getSrcLoc
1081          tok <- go [] input
1082          end <- getSrcLoc
1083          return (L (mkSrcSpan start end) tok)
1084     where go acc input
1085               = if isString input "#-}"
1086                    then do setInput input
1087                            return (mkTok (reverse acc))
1088                    else case alexGetChar input of
1089                           Just (c,i) -> go (c:acc) i
1090                           Nothing -> err input
1091           isString _ [] = True
1092           isString i (x:xs)
1093               = case alexGetChar i of
1094                   Just (c,i') | c == x    -> isString i' xs
1095                   _other -> False
1096           err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
1097
1098
1099 -- -----------------------------------------------------------------------------
1100 -- Strings & Chars
1101
1102 -- This stuff is horrible.  I hates it.
1103
1104 lex_string_tok :: Action
1105 lex_string_tok span _buf _len = do
1106   tok <- lex_string ""
1107   end <- getSrcLoc
1108   return (L (mkSrcSpan (srcSpanStart span) end) tok)
1109
1110 lex_string :: String -> P Token
1111 lex_string s = do
1112   i <- getInput
1113   case alexGetChar' i of
1114     Nothing -> lit_error
1115
1116     Just ('"',i)  -> do
1117         setInput i
1118         magicHash <- extension magicHashEnabled
1119         if magicHash
1120           then do
1121             i <- getInput
1122             case alexGetChar' i of
1123               Just ('#',i) -> do
1124                    setInput i
1125                    if any (> '\xFF') s
1126                     then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
1127                     else let s' = mkZFastString (reverse s) in
1128                          return (ITprimstring s')
1129                         -- mkZFastString is a hack to avoid encoding the
1130                         -- string in UTF-8.  We just want the exact bytes.
1131               _other ->
1132                 return (ITstring (mkFastString (reverse s)))
1133           else
1134                 return (ITstring (mkFastString (reverse s)))
1135
1136     Just ('\\',i)
1137         | Just ('&',i) <- next -> do
1138                 setInput i; lex_string s
1139         | Just (c,i) <- next, is_space c -> do
1140                 setInput i; lex_stringgap s
1141         where next = alexGetChar' i
1142
1143     Just (c, i) -> do
1144         c' <- lex_char c i
1145         lex_string (c':s)
1146
1147 lex_stringgap s = do
1148   c <- getCharOrFail
1149   case c of
1150     '\\' -> lex_string s
1151     c | is_space c -> lex_stringgap s
1152     _other -> lit_error
1153
1154
1155 lex_char_tok :: Action
1156 -- Here we are basically parsing character literals, such as 'x' or '\n'
1157 -- but, when Template Haskell is on, we additionally spot
1158 -- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
1159 -- but WIHTOUT CONSUMING the x or T part  (the parser does that).
1160 -- So we have to do two characters of lookahead: when we see 'x we need to
1161 -- see if there's a trailing quote
1162 lex_char_tok span _buf _len = do        -- We've seen '
1163    i1 <- getInput       -- Look ahead to first character
1164    let loc = srcSpanStart span
1165    case alexGetChar' i1 of
1166         Nothing -> lit_error
1167
1168         Just ('\'', i2@(AI end2 _ _)) -> do     -- We've seen ''
1169                   th_exts <- extension thEnabled
1170                   if th_exts then do
1171                         setInput i2
1172                         return (L (mkSrcSpan loc end2)  ITtyQuote)
1173                    else lit_error
1174
1175         Just ('\\', i2@(AI _end2 _ _)) -> do    -- We've seen 'backslash
1176                   setInput i2
1177                   lit_ch <- lex_escape
1178                   mc <- getCharOrFail   -- Trailing quote
1179                   if mc == '\'' then finish_char_tok loc lit_ch
1180                                 else do setInput i2; lit_error
1181
1182         Just (c, i2@(AI _end2 _ _))
1183                 | not (isAny c) -> lit_error
1184                 | otherwise ->
1185
1186                 -- We've seen 'x, where x is a valid character
1187                 --  (i.e. not newline etc) but not a quote or backslash
1188            case alexGetChar' i2 of      -- Look ahead one more character
1189                 Nothing -> lit_error
1190                 Just ('\'', i3) -> do   -- We've seen 'x'
1191                         setInput i3
1192                         finish_char_tok loc c
1193                 _other -> do            -- We've seen 'x not followed by quote
1194                                         -- If TH is on, just parse the quote only
1195                         th_exts <- extension thEnabled
1196                         let (AI end _ _) = i1
1197                         if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
1198                                    else do setInput i2; lit_error
1199
1200 finish_char_tok :: SrcLoc -> Char -> P (Located Token)
1201 finish_char_tok loc ch  -- We've already seen the closing quote
1202                         -- Just need to check for trailing #
1203   = do  magicHash <- extension magicHashEnabled
1204         i@(AI end _ _) <- getInput
1205         if magicHash then do
1206                 case alexGetChar' i of
1207                         Just ('#',i@(AI end _ _)) -> do
1208                                 setInput i
1209                                 return (L (mkSrcSpan loc end) (ITprimchar ch))
1210                         _other ->
1211                                 return (L (mkSrcSpan loc end) (ITchar ch))
1212                 else do
1213                    return (L (mkSrcSpan loc end) (ITchar ch))
1214
1215 lex_char :: Char -> AlexInput -> P Char
1216 lex_char c inp = do
1217   case c of
1218       '\\' -> do setInput inp; lex_escape
1219       c | isAny c -> do setInput inp; return c
1220       _other -> lit_error
1221
1222 isAny c | c > '\x7f' = isPrint c
1223         | otherwise  = is_any c
1224
1225 lex_escape :: P Char
1226 lex_escape = do
1227   c <- getCharOrFail
1228   case c of
1229         'a'   -> return '\a'
1230         'b'   -> return '\b'
1231         'f'   -> return '\f'
1232         'n'   -> return '\n'
1233         'r'   -> return '\r'
1234         't'   -> return '\t'
1235         'v'   -> return '\v'
1236         '\\'  -> return '\\'
1237         '"'   -> return '\"'
1238         '\''  -> return '\''
1239         '^'   -> do c <- getCharOrFail
1240                     if c >= '@' && c <= '_'
1241                         then return (chr (ord c - ord '@'))
1242                         else lit_error
1243
1244         'x'   -> readNum is_hexdigit 16 hexDigit
1245         'o'   -> readNum is_octdigit  8 octDecDigit
1246         x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)
1247
1248         c1 ->  do
1249            i <- getInput
1250            case alexGetChar' i of
1251             Nothing -> lit_error
1252             Just (c2,i2) ->
1253               case alexGetChar' i2 of
1254                 Nothing -> do setInput i2; lit_error
1255                 Just (c3,i3) ->
1256                    let str = [c1,c2,c3] in
1257                    case [ (c,rest) | (p,c) <- silly_escape_chars,
1258                                      Just rest <- [maybePrefixMatch p str] ] of
1259                           (escape_char,[]):_ -> do
1260                                 setInput i3
1261                                 return escape_char
1262                           (escape_char,_:_):_ -> do
1263                                 setInput i2
1264                                 return escape_char
1265                           [] -> lit_error
1266
1267 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char
1268 readNum is_digit base conv = do
1269   i <- getInput
1270   c <- getCharOrFail
1271   if is_digit c
1272         then readNum2 is_digit base conv (conv c)
1273         else do setInput i; lit_error
1274
1275 readNum2 is_digit base conv i = do
1276   input <- getInput
1277   read i input
1278   where read i input = do
1279           case alexGetChar' input of
1280             Just (c,input') | is_digit c -> do
1281                 read (i*base + conv c) input'
1282             _other -> do
1283                 if i >= 0 && i <= 0x10FFFF
1284                    then do setInput input; return (chr i)
1285                    else lit_error
1286
1287 silly_escape_chars = [
1288         ("NUL", '\NUL'),
1289         ("SOH", '\SOH'),
1290         ("STX", '\STX'),
1291         ("ETX", '\ETX'),
1292         ("EOT", '\EOT'),
1293         ("ENQ", '\ENQ'),
1294         ("ACK", '\ACK'),
1295         ("BEL", '\BEL'),
1296         ("BS", '\BS'),
1297         ("HT", '\HT'),
1298         ("LF", '\LF'),
1299         ("VT", '\VT'),
1300         ("FF", '\FF'),
1301         ("CR", '\CR'),
1302         ("SO", '\SO'),
1303         ("SI", '\SI'),
1304         ("DLE", '\DLE'),
1305         ("DC1", '\DC1'),
1306         ("DC2", '\DC2'),
1307         ("DC3", '\DC3'),
1308         ("DC4", '\DC4'),
1309         ("NAK", '\NAK'),
1310         ("SYN", '\SYN'),
1311         ("ETB", '\ETB'),
1312         ("CAN", '\CAN'),
1313         ("EM", '\EM'),
1314         ("SUB", '\SUB'),
1315         ("ESC", '\ESC'),
1316         ("FS", '\FS'),
1317         ("GS", '\GS'),
1318         ("RS", '\RS'),
1319         ("US", '\US'),
1320         ("SP", '\SP'),
1321         ("DEL", '\DEL')
1322         ]
1323
1324 -- before calling lit_error, ensure that the current input is pointing to
1325 -- the position of the error in the buffer.  This is so that we can report
1326 -- a correct location to the user, but also so we can detect UTF-8 decoding
1327 -- errors if they occur.
1328 lit_error = lexError "lexical error in string/character literal"
1329
1330 getCharOrFail :: P Char
1331 getCharOrFail =  do
1332   i <- getInput
1333   case alexGetChar' i of
1334         Nothing -> lexError "unexpected end-of-file in string/character literal"
1335         Just (c,i)  -> do setInput i; return c
1336
1337 -- -----------------------------------------------------------------------------
1338 -- QuasiQuote
1339
1340 lex_quasiquote_tok :: Action
1341 lex_quasiquote_tok span buf len = do
1342   let quoter = reverse $ takeWhile (/= '$')
1343                $ reverse $ lexemeToString buf (len - 1)
1344   quoteStart <- getSrcLoc
1345   quote <- lex_quasiquote ""
1346   end <- getSrcLoc
1347   return (L (mkSrcSpan (srcSpanStart span) end)
1348            (ITquasiQuote (mkFastString quoter,
1349                           mkFastString (reverse quote),
1350                           mkSrcSpan quoteStart end)))
1351
1352 lex_quasiquote :: String -> P String
1353 lex_quasiquote s = do
1354   i <- getInput
1355   case alexGetChar' i of
1356     Nothing -> lit_error
1357
1358     Just ('\\',i)
1359         | Just ('|',i) <- next -> do
1360                 setInput i; lex_quasiquote ('|' : s)
1361         | Just (']',i) <- next -> do
1362                 setInput i; lex_quasiquote (']' : s)
1363         where next = alexGetChar' i
1364
1365     Just ('|',i)
1366         | Just (']',i) <- next -> do
1367                 setInput i; return s
1368         where next = alexGetChar' i
1369
1370     Just (c, i) -> do
1371          setInput i; lex_quasiquote (c : s)
1372
1373 -- -----------------------------------------------------------------------------
1374 -- Warnings
1375
1376 warn :: DynFlag -> SDoc -> Action
1377 warn option warning srcspan _buf _len = do
1378     addWarning option srcspan warning
1379     lexToken
1380
1381 -- -----------------------------------------------------------------------------
1382 -- The Parse Monad
1383
1384 data LayoutContext
1385   = NoLayout
1386   | Layout !Int
1387   deriving Show
1388
1389 data ParseResult a
1390   = POk PState a
1391   | PFailed
1392         SrcSpan         -- The start and end of the text span related to
1393                         -- the error.  Might be used in environments which can
1394                         -- show this span, e.g. by highlighting it.
1395         Message         -- The error message
1396
1397 data PState = PState {
1398         buffer     :: StringBuffer,
1399     dflags     :: DynFlags,
1400     messages   :: Messages,
1401         last_loc   :: SrcSpan,  -- pos of previous token
1402         last_offs  :: !Int,     -- offset of the previous token from the
1403                                 -- beginning of  the current line.
1404                                 -- \t is equal to 8 spaces.
1405         last_len   :: !Int,     -- len of previous token
1406   last_line_len :: !Int,
1407         loc        :: SrcLoc,   -- current loc (end of prev token + 1)
1408         extsBitmap :: !Int,     -- bitmap that determines permitted extensions
1409         context    :: [LayoutContext],
1410         lex_state  :: [Int]
1411      }
1412         -- last_loc and last_len are used when generating error messages,
1413         -- and in pushCurrentContext only.  Sigh, if only Happy passed the
1414         -- current token to happyError, we could at least get rid of last_len.
1415         -- Getting rid of last_loc would require finding another way to
1416         -- implement pushCurrentContext (which is only called from one place).
1417
1418 newtype P a = P { unP :: PState -> ParseResult a }
1419
1420 instance Monad P where
1421   return = returnP
1422   (>>=) = thenP
1423   fail = failP
1424
1425 returnP :: a -> P a
1426 returnP a = a `seq` (P $ \s -> POk s a)
1427
1428 thenP :: P a -> (a -> P b) -> P b
1429 (P m) `thenP` k = P $ \ s ->
1430         case m s of
1431                 POk s1 a         -> (unP (k a)) s1
1432                 PFailed span err -> PFailed span err
1433
1434 failP :: String -> P a
1435 failP msg = P $ \s -> PFailed (last_loc s) (text msg)
1436
1437 failMsgP :: String -> P a
1438 failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
1439
1440 failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
1441 failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
1442
1443 failSpanMsgP :: SrcSpan -> SDoc -> P a
1444 failSpanMsgP span msg = P $ \_ -> PFailed span msg
1445
1446 extension :: (Int -> Bool) -> P Bool
1447 extension p = P $ \s -> POk s (p $! extsBitmap s)
1448
1449 getExts :: P Int
1450 getExts = P $ \s -> POk s (extsBitmap s)
1451
1452 setSrcLoc :: SrcLoc -> P ()
1453 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
1454
1455 getSrcLoc :: P SrcLoc
1456 getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
1457
1458 setLastToken :: SrcSpan -> Int -> Int -> P ()
1459 setLastToken loc len line_len = P $ \s -> POk s {
1460   last_loc=loc,
1461   last_len=len,
1462   last_line_len=line_len
1463 } ()
1464
1465 data AlexInput = AI SrcLoc {-#UNPACK#-}!Int StringBuffer
1466
1467 alexInputPrevChar :: AlexInput -> Char
1468 alexInputPrevChar (AI _ _ buf) = prevChar buf '\n'
1469
1470 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
1471 alexGetChar (AI loc ofs s)
1472   | atEnd s   = Nothing
1473   | otherwise = adj_c `seq` loc' `seq` ofs' `seq` s' `seq`
1474                 --trace (show (ord c)) $
1475                 Just (adj_c, (AI loc' ofs' s'))
1476   where (c,s') = nextChar s
1477         loc'   = advanceSrcLoc loc c
1478         ofs'   = advanceOffs c ofs
1479
1480         non_graphic     = '\x0'
1481         upper           = '\x1'
1482         lower           = '\x2'
1483         digit           = '\x3'
1484         symbol          = '\x4'
1485         space           = '\x5'
1486         other_graphic   = '\x6'
1487
1488         adj_c
1489           | c <= '\x06' = non_graphic
1490           | c <= '\x7f' = c
1491           -- Alex doesn't handle Unicode, so when Unicode
1492           -- character is encoutered we output these values
1493           -- with the actual character value hidden in the state.
1494           | otherwise =
1495                 case generalCategory c of
1496                   UppercaseLetter       -> upper
1497                   LowercaseLetter       -> lower
1498                   TitlecaseLetter       -> upper
1499                   ModifierLetter        -> other_graphic
1500                   OtherLetter           -> lower -- see #1103
1501                   NonSpacingMark        -> other_graphic
1502                   SpacingCombiningMark  -> other_graphic
1503                   EnclosingMark         -> other_graphic
1504                   DecimalNumber         -> digit
1505                   LetterNumber          -> other_graphic
1506                   OtherNumber           -> other_graphic
1507                   ConnectorPunctuation  -> other_graphic
1508                   DashPunctuation       -> other_graphic
1509                   OpenPunctuation       -> other_graphic
1510                   ClosePunctuation      -> other_graphic
1511                   InitialQuote          -> other_graphic
1512                   FinalQuote            -> other_graphic
1513                   OtherPunctuation      -> other_graphic
1514                   MathSymbol            -> symbol
1515                   CurrencySymbol        -> symbol
1516                   ModifierSymbol        -> symbol
1517                   OtherSymbol           -> symbol
1518                   Space                 -> space
1519                   _other                -> non_graphic
1520
1521 -- This version does not squash unicode characters, it is used when
1522 -- lexing strings.
1523 alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
1524 alexGetChar' (AI loc ofs s)
1525   | atEnd s   = Nothing
1526   | otherwise = c `seq` loc' `seq` ofs' `seq` s' `seq`
1527                 --trace (show (ord c)) $
1528                 Just (c, (AI loc' ofs' s'))
1529   where (c,s') = nextChar s
1530         loc'   = advanceSrcLoc loc c
1531         ofs'   = advanceOffs c ofs
1532
1533 advanceOffs :: Char -> Int -> Int
1534 advanceOffs '\n' _    = 0
1535 advanceOffs '\t' offs = (offs `quot` 8 + 1) * 8
1536 advanceOffs _    offs = offs + 1
1537
1538 getInput :: P AlexInput
1539 getInput = P $ \s@PState{ loc=l, last_offs=o, buffer=b } -> POk s (AI l o b)
1540
1541 setInput :: AlexInput -> P ()
1542 setInput (AI l o b) = P $ \s -> POk s{ loc=l, last_offs=o, buffer=b } ()
1543
1544 pushLexState :: Int -> P ()
1545 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
1546
1547 popLexState :: P Int
1548 popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
1549
1550 getLexState :: P Int
1551 getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
1552
1553 -- for reasons of efficiency, flags indicating language extensions (eg,
1554 -- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed
1555 -- integer
1556
1557 genericsBit, ffiBit, parrBit :: Int
1558 genericsBit = 0 -- {| and |}
1559 ffiBit     = 1
1560 parrBit    = 2
1561 arrowsBit  = 4
1562 thBit      = 5
1563 ipBit      = 6
1564 explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
1565 bangPatBit = 8  -- Tells the parser to understand bang-patterns
1566                 -- (doesn't affect the lexer)
1567 tyFamBit   = 9  -- indexed type families: 'family' keyword and kind sigs
1568 haddockBit = 10 -- Lex and parse Haddock comments
1569 magicHashBit = 11 -- # in both functions and operators
1570 kindSigsBit = 12 -- Kind signatures on type variables
1571 recursiveDoBit = 13 -- mdo
1572 unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
1573 unboxedTuplesBit = 15 -- (# and #)
1574 standaloneDerivingBit = 16 -- standalone instance deriving declarations
1575 transformComprehensionsBit = 17
1576 qqBit      = 18 -- enable quasiquoting
1577
1578 genericsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
1579 always           _     = True
1580 genericsEnabled  flags = testBit flags genericsBit
1581 ffiEnabled       flags = testBit flags ffiBit
1582 parrEnabled      flags = testBit flags parrBit
1583 arrowsEnabled    flags = testBit flags arrowsBit
1584 thEnabled        flags = testBit flags thBit
1585 ipEnabled        flags = testBit flags ipBit
1586 explicitForallEnabled flags = testBit flags explicitForallBit
1587 bangPatEnabled   flags = testBit flags bangPatBit
1588 tyFamEnabled     flags = testBit flags tyFamBit
1589 haddockEnabled   flags = testBit flags haddockBit
1590 magicHashEnabled flags = testBit flags magicHashBit
1591 kindSigsEnabled  flags = testBit flags kindSigsBit
1592 recursiveDoEnabled flags = testBit flags recursiveDoBit
1593 unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
1594 unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
1595 standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit
1596 transformComprehensionsEnabled flags = testBit flags transformComprehensionsBit
1597 qqEnabled        flags = testBit flags qqBit
1598
1599 -- PState for parsing options pragmas
1600 --
1601 pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
1602 pragState dynflags buf loc =
1603   PState {
1604       buffer        = buf,
1605       messages      = emptyMessages,
1606       dflags        = dynflags,
1607       last_loc      = mkSrcSpan loc loc,
1608       last_offs     = 0,
1609       last_len      = 0,
1610       last_line_len = 0,
1611       loc           = loc,
1612       extsBitmap    = 0,
1613       context       = [],
1614       lex_state     = [bol, option_prags, 0]
1615     }
1616
1617
1618 -- create a parse state
1619 --
1620 mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
1621 mkPState buf loc flags  =
1622   PState {
1623       buffer          = buf,
1624       dflags        = flags,
1625       messages      = emptyMessages,
1626       last_loc      = mkSrcSpan loc loc,
1627       last_offs     = 0,
1628       last_len      = 0,
1629       last_line_len = 0,
1630       loc           = loc,
1631       extsBitmap    = fromIntegral bitmap,
1632       context       = [],
1633       lex_state     = [bol, 0]
1634         -- we begin in the layout state if toplev_layout is set
1635     }
1636     where
1637       bitmap = genericsBit `setBitIf` dopt Opt_Generics flags
1638                .|. ffiBit       `setBitIf` dopt Opt_ForeignFunctionInterface flags
1639                .|. parrBit      `setBitIf` dopt Opt_PArr         flags
1640                .|. arrowsBit    `setBitIf` dopt Opt_Arrows       flags
1641                .|. thBit        `setBitIf` dopt Opt_TemplateHaskell flags
1642                .|. qqBit        `setBitIf` dopt Opt_QuasiQuotes flags
1643                .|. ipBit        `setBitIf` dopt Opt_ImplicitParams flags
1644                .|. explicitForallBit `setBitIf` dopt Opt_ScopedTypeVariables flags
1645                .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
1646                .|. explicitForallBit `setBitIf` dopt Opt_ExistentialQuantification flags
1647                .|. explicitForallBit `setBitIf` dopt Opt_Rank2Types flags
1648                .|. explicitForallBit `setBitIf` dopt Opt_RankNTypes flags
1649                .|. bangPatBit   `setBitIf` dopt Opt_BangPatterns flags
1650                .|. tyFamBit     `setBitIf` dopt Opt_TypeFamilies flags
1651                .|. haddockBit   `setBitIf` dopt Opt_Haddock      flags
1652                .|. magicHashBit `setBitIf` dopt Opt_MagicHash    flags
1653                .|. kindSigsBit  `setBitIf` dopt Opt_KindSignatures flags
1654                .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
1655                .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
1656                .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
1657                .|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags
1658            .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags
1659       --
1660       setBitIf :: Int -> Bool -> Int
1661       b `setBitIf` cond | cond      = bit b
1662                         | otherwise = 0
1663
1664 addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
1665 addWarning option srcspan warning
1666  = P $ \s@PState{messages=(ws,es), dflags=d} ->
1667        let warning' = mkWarnMsg srcspan alwaysQualify warning
1668            ws' = if dopt option d then ws `snocBag` warning' else ws
1669        in POk s{messages=(ws', es)} ()
1670
1671 getMessages :: PState -> Messages
1672 getMessages PState{messages=ms} = ms
1673
1674 getContext :: P [LayoutContext]
1675 getContext = P $ \s@PState{context=ctx} -> POk s ctx
1676
1677 setContext :: [LayoutContext] -> P ()
1678 setContext ctx = P $ \s -> POk s{context=ctx} ()
1679
1680 popContext :: P ()
1681 popContext = P $ \ s@(PState{ buffer = buf, context = ctx,
1682                               last_len = len, last_loc = last_loc }) ->
1683   case ctx of
1684         (_:tl) -> POk s{ context = tl } ()
1685         []     -> PFailed last_loc (srcParseErr buf len)
1686
1687 -- Push a new layout context at the indentation of the last token read.
1688 -- This is only used at the outer level of a module when the 'module'
1689 -- keyword is missing.
1690 pushCurrentContext :: P ()
1691 pushCurrentContext = P $ \ s@PState{ last_offs=offs, last_line_len=len, context=ctx } ->
1692     POk s{context = Layout (offs-len) : ctx} ()
1693 --trace ("off: " ++ show offs ++ ", len: " ++ show len) $ POk s{context = Layout (offs-len) : ctx} ()
1694
1695 getOffside :: P Ordering
1696 getOffside = P $ \s@PState{last_offs=offs, context=stk} ->
1697                 let ord = case stk of
1698                         (Layout n:_) -> compare offs n
1699                         _            -> GT
1700                 in POk s ord
1701
1702 -- ---------------------------------------------------------------------------
1703 -- Construct a parse error
1704
1705 srcParseErr
1706   :: StringBuffer       -- current buffer (placed just after the last token)
1707   -> Int                -- length of the previous token
1708   -> Message
1709 srcParseErr buf len
1710   = hcat [ if null token
1711              then ptext (sLit "parse error (possibly incorrect indentation)")
1712              else hcat [ptext (sLit "parse error on input "),
1713                         char '`', text token, char '\'']
1714     ]
1715   where token = lexemeToString (offsetBytes (-len) buf) len
1716
1717 -- Report a parse failure, giving the span of the previous token as
1718 -- the location of the error.  This is the entry point for errors
1719 -- detected during parsing.
1720 srcParseFail :: P a
1721 srcParseFail = P $ \PState{ buffer = buf, last_len = len,
1722                             last_loc = last_loc } ->
1723     PFailed last_loc (srcParseErr buf len)
1724
1725 -- A lexical error is reported at a particular position in the source file,
1726 -- not over a token range.
1727 lexError :: String -> P a
1728 lexError str = do
1729   loc <- getSrcLoc
1730   (AI end _ buf) <- getInput
1731   reportLexError loc end buf str
1732
1733 -- -----------------------------------------------------------------------------
1734 -- This is the top-level function: called from the parser each time a
1735 -- new token is to be read from the input.
1736
1737 lexer :: (Located Token -> P a) -> P a
1738 lexer cont = do
1739   tok@(L _span _tok__) <- lexToken
1740 --  trace ("token: " ++ show tok__) $ do
1741   cont tok
1742
1743 lexToken :: P (Located Token)
1744 lexToken = do
1745   inp@(AI loc1 _ buf) <- getInput
1746   sc <- getLexState
1747   exts <- getExts
1748   case alexScanUser exts inp sc of
1749     AlexEOF -> do
1750         let span = mkSrcSpan loc1 loc1
1751         setLastToken span 0 0
1752         return (L span ITeof)
1753     AlexError (AI loc2 _ buf) ->
1754         reportLexError loc1 loc2 buf "lexical error"
1755     AlexSkip inp2 _ -> do
1756         setInput inp2
1757         lexToken
1758     AlexToken inp2@(AI end _ buf2) _ t -> do
1759         setInput inp2
1760         let span = mkSrcSpan loc1 end
1761         let bytes = byteDiff buf buf2
1762         span `seq` setLastToken span bytes bytes
1763         t span buf bytes
1764
1765 reportLexError loc1 loc2 buf str
1766   | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
1767   | otherwise =
1768   let
1769         c = fst (nextChar buf)
1770   in
1771   if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
1772     then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
1773     else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
1774 }