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