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