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