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