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