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