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