compiler/parser/Lexer.x

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