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