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