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, standaloneDerivingEnabled, 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> \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>
 230   "{-#" $whitechar* (RULES|rules) / { ifExtension explicitForallEnabled } { token ITrules_prag }
 231
 232 <0,option_prags> {
 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> {
 270         -- This is to catch things like {-# OPTIONS OPTIONS_HUGS ...
 271   "{-#" $whitechar* $idchar+            { nested_comment lexToken }
 272 }
 273
 274 -- '0' state: ordinary lexemes
 275
 276 -- Haddock comments
 277
 278 <0> {
 279   "-- " $docsym    / { ifExtension haddockEnabled } { multiline_doc_comment }
 280   "{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
 281 }
 282
 283 -- "special" symbols
 284
 285 <0> {
 286   "[:" / { ifExtension parrEnabled }    { token ITopabrack }
 287   ":]" / { ifExtension parrEnabled }    { token ITcpabrack }
 288 }
 289
 290 <0> {
 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> {
 302   "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
 303                                         { special IToparenbar }
 304   "|)" / { ifExtension arrowsEnabled }  { special ITcparenbar }
 305 }
 306
 307 <0> {
 308   \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
 309 }
 310
 311 <0> {
 312   "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol }
 313          { token IToubxparen }
 314   "#)" / { ifExtension unboxedTuplesEnabled }
 315          { token ITcubxparen }
 316 }
 317
 318 <0> {
 319   "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
 320   "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
 321 }
 322
 323 <0,option_prags> {
 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> {
 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> {
 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> {
 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> {
 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 <0> {
 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 \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
 383   0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
 384   0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
 385   @negative @decimal \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
 386   @negative 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
 387   @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { 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 \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }
 392   @signed @floating_point \# \# / { ifExtension magicHashEnabled } { 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> {
 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 -> kindSigsEnabled i || tyFamEnabled i)
 660         -- For 'forall a . t'
 661        ,(".", ITdot, explicitForallEnabled)
 662
 663        ,("-<",  ITlarrowtail, arrowsEnabled)
 664        ,(">-",  ITrarrowtail, arrowsEnabled)
 665        ,("-<<", ITLarrowtail, arrowsEnabled)
 666        ,(">>-", ITRarrowtail, arrowsEnabled)
 667
 668 #if __GLASGOW_HASKELL__ >= 605
 669        ,("∷",   ITdcolon, unicodeSyntaxEnabled)
 670        ,("⇒",   ITdarrow, unicodeSyntaxEnabled)
 671        ,("∀",   ITforall, \i -> unicodeSyntaxEnabled i &&
 672                                 explicitForallEnabled i)
 673        ,("→",   ITrarrow, unicodeSyntaxEnabled)
 674        ,("←",   ITlarrow, unicodeSyntaxEnabled)
 675        ,("⋯",   ITdotdot, unicodeSyntaxEnabled)
 676         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
 677         -- form part of a large operator.  This would let us have a better
 678         -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
 679 #endif
 680        ]
 681
 682 -- -----------------------------------------------------------------------------
 683 -- Lexer actions
 684
 685 type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
 686
 687 special :: Token -> Action
 688 special tok span _buf len = return (L span tok)
 689
 690 token, layout_token :: Token -> Action
 691 token t span buf len = return (L span t)
 692 layout_token t span buf len = pushLexState layout >> return (L span t)
 693
 694 idtoken :: (StringBuffer -> Int -> Token) -> Action
 695 idtoken f span buf len = return (L span $! (f buf len))
 696
 697 skip_one_varid :: (FastString -> Token) -> Action
 698 skip_one_varid f span buf len
 699   = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
 700
 701 strtoken :: (String -> Token) -> Action
 702 strtoken f span buf len =
 703   return (L span $! (f $! lexemeToString buf len))
 704
 705 init_strtoken :: Int -> (String -> Token) -> Action
 706 -- like strtoken, but drops the last N character(s)
 707 init_strtoken drop f span buf len =
 708   return (L span $! (f $! lexemeToString buf (len-drop)))
 709
 710 begin :: Int -> Action
 711 begin code _span _str _len = do pushLexState code; lexToken
 712
 713 pop :: Action
 714 pop _span _buf _len = do popLexState; lexToken
 715
 716 pop_and :: Action -> Action
 717 pop_and act span buf len = do popLexState; act span buf len
 718
 719 {-# INLINE nextCharIs #-}
 720 nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
 721
 722 notFollowedBy char _ _ _ (AI _ _ buf)
 723   = nextCharIs buf (/=char)
 724
 725 notFollowedBySymbol _ _ _ (AI _ _ buf)
 726   = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
 727
 728 -- We must reject doc comments as being ordinary comments everywhere.
 729 -- In some cases the doc comment will be selected as the lexeme due to
 730 -- maximal munch, but not always, because the nested comment rule is
 731 -- valid in all states, but the doc-comment rules are only valid in
 732 -- the non-layout states.
 733 isNormalComment bits _ _ (AI _ _ buf)
 734   | haddockEnabled bits = notFollowedByDocOrPragma
 735   | otherwise           = nextCharIs buf (/='#')
 736   where
 737     notFollowedByDocOrPragma
 738        = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
 739
 740 spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
 741
 742 haddockDisabledAnd p bits _ _ (AI _ _ buf)
 743   = if haddockEnabled bits then False else (p buf)
 744
 745 atEOL _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf == '\n'
 746
 747 ifExtension pred bits _ _ _ = pred bits
 748
 749 multiline_doc_comment :: Action
 750 multiline_doc_comment span buf _len = withLexedDocType (worker "")
 751   where
 752     worker commentAcc input docType oneLine = case alexGetChar input of
 753       Just ('\n', input')
 754         | oneLine -> docCommentEnd input commentAcc docType buf span
 755         | otherwise -> case checkIfCommentLine input' of
 756           Just input -> worker ('\n':commentAcc) input docType False
 757           Nothing -> docCommentEnd input commentAcc docType buf span
 758       Just (c, input) -> worker (c:commentAcc) input docType oneLine
 759       Nothing -> docCommentEnd input commentAcc docType buf span
 760
 761     checkIfCommentLine input = check (dropNonNewlineSpace input)
 762       where
 763         check input = case alexGetChar input of
 764           Just ('-', input) -> case alexGetChar input of
 765             Just ('-', input) -> case alexGetChar input of
 766               Just (c, _) | c /= '-' -> Just input
 767               _ -> Nothing
 768             _ -> Nothing
 769           _ -> Nothing
 770
 771         dropNonNewlineSpace input = case alexGetChar input of
 772           Just (c, input')
 773             | isSpace c && c /= '\n' -> dropNonNewlineSpace input'
 774             | otherwise -> input
 775           Nothing -> input
 776
 777 {-
 778   nested comments require traversing by hand, they can't be parsed
 779   using regular expressions.
 780 -}
 781 nested_comment :: P (Located Token) -> Action
 782 nested_comment cont span _str _len = do
 783   input <- getInput
 784   go 1 input
 785   where
 786     go 0 input = do setInput input; cont
 787     go n input = case alexGetChar input of
 788       Nothing -> errBrace input span
 789       Just ('-',input) -> case alexGetChar input of
 790         Nothing  -> errBrace input span
 791         Just ('\125',input) -> go (n-1) input
 792         Just (c,_)          -> go n input
 793       Just ('\123',input) -> case alexGetChar input of
 794         Nothing  -> errBrace input span
 795         Just ('-',input) -> go (n+1) input
 796         Just (c,_)       -> go n input
 797       Just (c,input) -> go n input
 798
 799 nested_doc_comment :: Action
 800 nested_doc_comment span buf _len = withLexedDocType (go "")
 801   where
 802     go commentAcc input docType _ = case alexGetChar input of
 803       Nothing -> errBrace input span
 804       Just ('-',input) -> case alexGetChar input of
 805         Nothing -> errBrace input span
 806         Just ('\125',input@(AI end _ buf2)) ->
 807           docCommentEnd input commentAcc docType buf span
 808         Just (c,_) -> go ('-':commentAcc) input docType False
 809       Just ('\123', input) -> case alexGetChar input of
 810         Nothing  -> errBrace input span
 811         Just ('-',input) -> do
 812           setInput input
 813           let cont = do input <- getInput; go commentAcc input docType False
 814           nested_comment cont span buf _len
 815         Just (c,_) -> go ('\123':commentAcc) input docType False
 816       Just (c,input) -> go (c:commentAcc) input docType False
 817
 818 withLexedDocType lexDocComment = do
 819   input@(AI _ _ buf) <- getInput
 820   case prevChar buf ' ' of
 821     '|' -> lexDocComment input ITdocCommentNext False
 822     '^' -> lexDocComment input ITdocCommentPrev False
 823     '$' -> lexDocComment input ITdocCommentNamed False
 824     '*' -> lexDocSection 1 input
 825  where
 826     lexDocSection n input = case alexGetChar input of
 827       Just ('*', input) -> lexDocSection (n+1) input
 828       Just (c, _) -> lexDocComment input (ITdocSection n) True
 829       Nothing -> do setInput input; lexToken -- eof reached, lex it normally
 830
 831 -- docCommentEnd
 832 -------------------------------------------------------------------------------
 833 -- This function is quite tricky. We can't just return a new token, we also
 834 -- need to update the state of the parser. Why? Because the token is longer
 835 -- than what was lexed by Alex, and the lexToken function doesn't know this, so
 836 -- it writes the wrong token length to the parser state. This function is
 837 -- called afterwards, so it can just update the state.
 838
 839 -- This is complicated by the fact that Haddock tokens can span multiple lines,
 840 -- which is something that the original lexer didn't account for.
 841 -- I have added last_line_len in the parser state which represents the length
 842 -- of the part of the token that is on the last line. It is now used for layout
 843 -- calculation in pushCurrentContext instead of last_len. last_len is, like it
 844 -- was before, the full length of the token, and it is now only used for error
 845 -- messages. /Waern
 846
 847 docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
 848                  SrcSpan -> P (Located Token)
 849 docCommentEnd input commentAcc docType buf span = do
 850   setInput input
 851   let (AI loc last_offs nextBuf) = input
 852       comment = reverse commentAcc
 853       span' = mkSrcSpan (srcSpanStart span) loc
 854       last_len = byteDiff buf nextBuf
 855
 856       last_line_len = if (last_offs - last_len < 0)
 857         then last_offs
 858         else last_len
 859
 860   span `seq` setLastToken span' last_len last_line_len
 861   return (L span' (docType comment))
 862
 863 errBrace (AI end _ _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
 864
 865 open_brace, close_brace :: Action
 866 open_brace span _str _len = do
 867   ctx <- getContext
 868   setContext (NoLayout:ctx)
 869   return (L span ITocurly)
 870 close_brace span _str _len = do
 871   popContext
 872   return (L span ITccurly)
 873
 874 -- We have to be careful not to count M.<varid> as a qualified name
 875 -- when <varid> is a keyword.  We hack around this by catching
 876 -- the offending tokens afterward, and re-lexing in a different state.
 877 check_qvarid span buf len = do
 878   case lookupUFM reservedWordsFM var of
 879         Just (keyword,exts)
 880           | not (isSpecial keyword) ->
 881           if exts == 0
 882              then try_again
 883              else do
 884                 b <- extension (\i -> exts .&. i /= 0)
 885                 if b then try_again
 886                      else return token
 887         _other -> return token
 888   where
 889         (mod,var) = splitQualName buf len
 890         token     = L span (ITqvarid (mod,var))
 891
 892         try_again = do
 893                 (AI _ offs _) <- getInput
 894                 setInput (AI (srcSpanStart span) (offs-len) buf)
 895                 pushLexState bad_qvarid
 896                 lexToken
 897
 898 qvarid buf len = ITqvarid $! splitQualName buf len
 899 qconid buf len = ITqconid $! splitQualName buf len
 900
 901 splitQualName :: StringBuffer -> Int -> (FastString,FastString)
 902 -- takes a StringBuffer and a length, and returns the module name
 903 -- and identifier parts of a qualified name.  Splits at the *last* dot,
 904 -- because of hierarchical module names.
 905 splitQualName orig_buf len = split orig_buf orig_buf
 906   where
 907     split buf dot_buf
 908         | orig_buf `byteDiff` buf >= len  = done dot_buf
 909         | c == '.'                        = found_dot buf'
 910         | otherwise                       = split buf' dot_buf
 911       where
 912        (c,buf') = nextChar buf
 913
 914     -- careful, we might get names like M....
 915     -- so, if the character after the dot is not upper-case, this is
 916     -- the end of the qualifier part.
 917     found_dot buf -- buf points after the '.'
 918         | isUpper c    = split buf' buf
 919         | otherwise    = done buf
 920       where
 921        (c,buf') = nextChar buf
 922
 923     done dot_buf =
 924         (lexemeToFastString orig_buf (qual_size - 1),
 925          lexemeToFastString dot_buf (len - qual_size))
 926       where
 927         qual_size = orig_buf `byteDiff` dot_buf
 928
 929 varid span buf len =
 930   case lookupUFM reservedWordsFM fs of
 931         Just (keyword,0)    -> do
 932                 maybe_layout keyword
 933                 return (L span keyword)
 934         Just (keyword,exts) -> do
 935                 b <- extension (\i -> exts .&. i /= 0)
 936                 if b then do maybe_layout keyword
 937                              return (L span keyword)
 938                      else return (L span (ITvarid fs))
 939         _other -> return (L span (ITvarid fs))
 940   where
 941         fs = lexemeToFastString buf len
 942
 943 conid buf len = ITconid fs
 944   where fs = lexemeToFastString buf len
 945
 946 qvarsym buf len = ITqvarsym $! splitQualName buf len
 947 qconsym buf len = ITqconsym $! splitQualName buf len
 948
 949 varsym = sym ITvarsym
 950 consym = sym ITconsym
 951
 952 sym con span buf len =
 953   case lookupUFM reservedSymsFM fs of
 954         Just (keyword,exts) -> do
 955                 b <- extension exts
 956                 if b then return (L span keyword)
 957                      else return (L span $! con fs)
 958         _other -> return (L span $! con fs)
 959   where
 960         fs = lexemeToFastString buf len
 961
 962 -- Variations on the integral numeric literal.
 963 tok_integral :: (Integer -> Token)
 964      -> (Integer -> Integer)
 965  --    -> (StringBuffer -> StringBuffer) -> (Int -> Int)
 966      -> Int -> Int
 967      -> (Integer, (Char->Int)) -> Action
 968 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len =
 969   return $ L span $ itint $! transint $ parseUnsignedInteger
 970      (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
 971
 972 -- some conveniences for use with tok_integral
 973 tok_num = tok_integral ITinteger
 974 tok_primint = tok_integral ITprimint
 975 positive = id
 976 negative = negate
 977 decimal = (10,octDecDigit)
 978 octal = (8,octDecDigit)
 979 hexadecimal = (16,hexDigit)
 980
 981 -- readRational can understand negative rationals, exponents, everything.
 982 tok_float        str = ITrational   $! readRational str
 983 tok_primfloat    str = ITprimfloat  $! readRational str
 984 tok_primdouble   str = ITprimdouble $! readRational str
 985
 986 -- -----------------------------------------------------------------------------
 987 -- Layout processing
 988
 989 -- we're at the first token on a line, insert layout tokens if necessary
 990 do_bol :: Action
 991 do_bol span _str _len = do
 992         pos <- getOffside
 993         case pos of
 994             LT -> do
 995                 --trace "layout: inserting '}'" $ do
 996                 popContext
 997                 -- do NOT pop the lex state, we might have a ';' to insert
 998                 return (L span ITvccurly)
 999             EQ -> do
1000                 --trace "layout: inserting ';'" $ do
1001                 popLexState
1002                 return (L span ITsemi)
1003             GT -> do
1004                 popLexState
1005                 lexToken
1006
1007 -- certain keywords put us in the "layout" state, where we might
1008 -- add an opening curly brace.
1009 maybe_layout ITdo       = pushLexState layout_do
1010 maybe_layout ITmdo      = pushLexState layout_do
1011 maybe_layout ITof       = pushLexState layout
1012 maybe_layout ITlet      = pushLexState layout
1013 maybe_layout ITwhere    = pushLexState layout
1014 maybe_layout ITrec      = pushLexState layout
1015 maybe_layout _          = return ()
1016
1017 -- Pushing a new implicit layout context.  If the indentation of the
1018 -- next token is not greater than the previous layout context, then
1019 -- Haskell 98 says that the new layout context should be empty; that is
1020 -- the lexer must generate {}.
1021 --
1022 -- We are slightly more lenient than this: when the new context is started
1023 -- by a 'do', then we allow the new context to be at the same indentation as
1024 -- the previous context.  This is what the 'strict' argument is for.
1025 --
1026 new_layout_context strict span _buf _len = do
1027     popLexState
1028     (AI _ offset _) <- getInput
1029     ctx <- getContext
1030     case ctx of
1031         Layout prev_off : _  |
1032            (strict     && prev_off >= offset  ||
1033             not strict && prev_off > offset) -> do
1034                 -- token is indented to the left of the previous context.
1035                 -- we must generate a {} sequence now.
1036                 pushLexState layout_left
1037                 return (L span ITvocurly)
1038         other -> do
1039                 setContext (Layout offset : ctx)
1040                 return (L span ITvocurly)
1041
1042 do_layout_left span _buf _len = do
1043     popLexState
1044     pushLexState bol  -- we must be at the start of a line
1045     return (L span ITvccurly)
1046
1047 -- -----------------------------------------------------------------------------
1048 -- LINE pragmas
1049
1050 setLine :: Int -> Action
1051 setLine code span buf len = do
1052   let line = parseUnsignedInteger buf len 10 octDecDigit
1053   setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
1054         -- subtract one: the line number refers to the *following* line
1055   popLexState
1056   pushLexState code
1057   lexToken
1058
1059 setFile :: Int -> Action
1060 setFile code span buf len = do
1061   let file = lexemeToFastString (stepOn buf) (len-2)
1062   setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
1063   popLexState
1064   pushLexState code
1065   lexToken
1066
1067
1068 -- -----------------------------------------------------------------------------
1069 -- Options, includes and language pragmas.
1070
1071 lex_string_prag :: (String -> Token) -> Action
1072 lex_string_prag mkTok span buf len
1073     = do input <- getInput
1074          start <- getSrcLoc
1075          tok <- go [] input
1076          end <- getSrcLoc
1077          return (L (mkSrcSpan start end) tok)
1078     where go acc input
1079               = if isString input "#-}"
1080                    then do setInput input
1081                            return (mkTok (reverse acc))
1082                    else case alexGetChar input of
1083                           Just (c,i) -> go (c:acc) i
1084                           Nothing -> err input
1085           isString i [] = True
1086           isString i (x:xs)
1087               = case alexGetChar i of
1088                   Just (c,i') | c == x    -> isString i' xs
1089                   _other -> False
1090           err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
1091
1092
1093 -- -----------------------------------------------------------------------------
1094 -- Strings & Chars
1095
1096 -- This stuff is horrible.  I hates it.
1097
1098 lex_string_tok :: Action
1099 lex_string_tok span buf len = do
1100   tok <- lex_string ""
1101   end <- getSrcLoc
1102   return (L (mkSrcSpan (srcSpanStart span) end) tok)
1103
1104 lex_string :: String -> P Token
1105 lex_string s = do
1106   i <- getInput
1107   case alexGetChar' i of
1108     Nothing -> lit_error
1109
1110     Just ('"',i)  -> do
1111         setInput i
1112         magicHash <- extension magicHashEnabled
1113         if magicHash
1114           then do
1115             i <- getInput
1116             case alexGetChar' i of
1117               Just ('#',i) -> do
1118                    setInput i
1119                    if any (> '\xFF') s
1120                     then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
1121                     else let s' = mkZFastString (reverse s) in
1122                          return (ITprimstring s')
1123                         -- mkZFastString is a hack to avoid encoding the
1124                         -- string in UTF-8.  We just want the exact bytes.
1125               _other ->
1126                 return (ITstring (mkFastString (reverse s)))
1127           else
1128                 return (ITstring (mkFastString (reverse s)))
1129
1130     Just ('\\',i)
1131         | Just ('&',i) <- next -> do
1132                 setInput i; lex_string s
1133         | Just (c,i) <- next, is_space c -> do
1134                 setInput i; lex_stringgap s
1135         where next = alexGetChar' i
1136
1137     Just (c, i) -> do
1138         c' <- lex_char c i
1139         lex_string (c':s)
1140
1141 lex_stringgap s = do
1142   c <- getCharOrFail
1143   case c of
1144     '\\' -> lex_string s
1145     c | is_space c -> lex_stringgap s
1146     _other -> lit_error
1147
1148
1149 lex_char_tok :: Action
1150 -- Here we are basically parsing character literals, such as 'x' or '\n'
1151 -- but, when Template Haskell is on, we additionally spot
1152 -- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
1153 -- but WIHTOUT CONSUMING the x or T part  (the parser does that).
1154 -- So we have to do two characters of lookahead: when we see 'x we need to
1155 -- see if there's a trailing quote
1156 lex_char_tok span buf len = do  -- We've seen '
1157    i1 <- getInput       -- Look ahead to first character
1158    let loc = srcSpanStart span
1159    case alexGetChar' i1 of
1160         Nothing -> lit_error
1161
1162         Just ('\'', i2@(AI end2 _ _)) -> do     -- We've seen ''
1163                   th_exts <- extension thEnabled
1164                   if th_exts then do
1165                         setInput i2
1166                         return (L (mkSrcSpan loc end2)  ITtyQuote)
1167                    else lit_error
1168
1169         Just ('\\', i2@(AI end2 _ _)) -> do     -- We've seen 'backslash
1170                   setInput i2
1171                   lit_ch <- lex_escape
1172                   mc <- getCharOrFail   -- Trailing quote
1173                   if mc == '\'' then finish_char_tok loc lit_ch
1174                                 else do setInput i2; lit_error
1175
1176         Just (c, i2@(AI end2 _ _))
1177                 | not (isAny c) -> lit_error
1178                 | otherwise ->
1179
1180                 -- We've seen 'x, where x is a valid character
1181                 --  (i.e. not newline etc) but not a quote or backslash
1182            case alexGetChar' i2 of      -- Look ahead one more character
1183                 Nothing -> lit_error
1184                 Just ('\'', i3) -> do   -- We've seen 'x'
1185                         setInput i3
1186                         finish_char_tok loc c
1187                 _other -> do            -- We've seen 'x not followed by quote
1188                                         -- If TH is on, just parse the quote only
1189                         th_exts <- extension thEnabled
1190                         let (AI end _ _) = i1
1191                         if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
1192                                    else do setInput i2; lit_error
1193
1194 finish_char_tok :: SrcLoc -> Char -> P (Located Token)
1195 finish_char_tok loc ch  -- We've already seen the closing quote
1196                         -- Just need to check for trailing #
1197   = do  magicHash <- extension magicHashEnabled
1198         i@(AI end _ _) <- getInput
1199         if magicHash then do
1200                 case alexGetChar' i of
1201                         Just ('#',i@(AI end _ _)) -> do
1202                                 setInput i
1203                                 return (L (mkSrcSpan loc end) (ITprimchar ch))
1204                         _other ->
1205                                 return (L (mkSrcSpan loc end) (ITchar ch))
1206                 else do
1207                    return (L (mkSrcSpan loc end) (ITchar ch))
1208
1209 lex_char :: Char -> AlexInput -> P Char
1210 lex_char c inp = do
1211   case c of
1212       '\\' -> do setInput inp; lex_escape
1213       c | isAny c -> do setInput inp; return c
1214       _other -> lit_error
1215
1216 isAny c | c > '\xff' = isPrint c
1217         | otherwise  = is_any c
1218
1219 lex_escape :: P Char
1220 lex_escape = do
1221   c <- getCharOrFail
1222   case c of
1223         'a'   -> return '\a'
1224         'b'   -> return '\b'
1225         'f'   -> return '\f'
1226         'n'   -> return '\n'
1227         'r'   -> return '\r'
1228         't'   -> return '\t'
1229         'v'   -> return '\v'
1230         '\\'  -> return '\\'
1231         '"'   -> return '\"'
1232         '\''  -> return '\''
1233         '^'   -> do c <- getCharOrFail
1234                     if c >= '@' && c <= '_'
1235                         then return (chr (ord c - ord '@'))
1236                         else lit_error
1237
1238         'x'   -> readNum is_hexdigit 16 hexDigit
1239         'o'   -> readNum is_octdigit  8 octDecDigit
1240         x | is_digit x -> readNum2 is_digit 10 octDecDigit (octDecDigit x)
1241
1242         c1 ->  do
1243            i <- getInput
1244            case alexGetChar' i of
1245             Nothing -> lit_error
1246             Just (c2,i2) ->
1247               case alexGetChar' i2 of
1248                 Nothing -> do setInput i2; lit_error
1249                 Just (c3,i3) ->
1250                    let str = [c1,c2,c3] in
1251                    case [ (c,rest) | (p,c) <- silly_escape_chars,
1252                                      Just rest <- [maybePrefixMatch p str] ] of
1253                           (escape_char,[]):_ -> do
1254                                 setInput i3
1255                                 return escape_char
1256                           (escape_char,_:_):_ -> do
1257                                 setInput i2
1258                                 return escape_char
1259                           [] -> lit_error
1260
1261 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char
1262 readNum is_digit base conv = do
1263   i <- getInput
1264   c <- getCharOrFail
1265   if is_digit c
1266         then readNum2 is_digit base conv (conv c)
1267         else do setInput i; lit_error
1268
1269 readNum2 is_digit base conv i = do
1270   input <- getInput
1271   read i input
1272   where read i input = do
1273           case alexGetChar' input of
1274             Just (c,input') | is_digit c -> do
1275                 read (i*base + conv c) input'
1276             _other -> do
1277                 if i >= 0 && i <= 0x10FFFF
1278                    then do setInput input; return (chr i)
1279                    else lit_error
1280
1281 silly_escape_chars = [
1282         ("NUL", '\NUL'),
1283         ("SOH", '\SOH'),
1284         ("STX", '\STX'),
1285         ("ETX", '\ETX'),
1286         ("EOT", '\EOT'),
1287         ("ENQ", '\ENQ'),
1288         ("ACK", '\ACK'),
1289         ("BEL", '\BEL'),
1290         ("BS", '\BS'),
1291         ("HT", '\HT'),
1292         ("LF", '\LF'),
1293         ("VT", '\VT'),
1294         ("FF", '\FF'),
1295         ("CR", '\CR'),
1296         ("SO", '\SO'),
1297         ("SI", '\SI'),
1298         ("DLE", '\DLE'),
1299         ("DC1", '\DC1'),
1300         ("DC2", '\DC2'),
1301         ("DC3", '\DC3'),
1302         ("DC4", '\DC4'),
1303         ("NAK", '\NAK'),
1304         ("SYN", '\SYN'),
1305         ("ETB", '\ETB'),
1306         ("CAN", '\CAN'),
1307         ("EM", '\EM'),
1308         ("SUB", '\SUB'),
1309         ("ESC", '\ESC'),
1310         ("FS", '\FS'),
1311         ("GS", '\GS'),
1312         ("RS", '\RS'),
1313         ("US", '\US'),
1314         ("SP", '\SP'),
1315         ("DEL", '\DEL')
1316         ]
1317
1318 -- before calling lit_error, ensure that the current input is pointing to
1319 -- the position of the error in the buffer.  This is so that we can report
1320 -- a correct location to the user, but also so we can detect UTF-8 decoding
1321 -- errors if they occur.
1322 lit_error = lexError "lexical error in string/character literal"
1323
1324 getCharOrFail :: P Char
1325 getCharOrFail =  do
1326   i <- getInput
1327   case alexGetChar' i of
1328         Nothing -> lexError "unexpected end-of-file in string/character literal"
1329         Just (c,i)  -> do setInput i; return c
1330
1331 -- -----------------------------------------------------------------------------
1332 -- Warnings
1333
1334 warn :: DynFlag -> SDoc -> Action
1335 warn option warning span _buf _len = do
1336     addWarning option (mkWarnMsg span alwaysQualify warning)
1337     lexToken
1338
1339 -- -----------------------------------------------------------------------------
1340 -- The Parse Monad
1341
1342 data LayoutContext
1343   = NoLayout
1344   | Layout !Int
1345   deriving Show
1346
1347 data ParseResult a
1348   = POk PState a
1349   | PFailed
1350         SrcSpan         -- The start and end of the text span related to
1351                         -- the error.  Might be used in environments which can
1352                         -- show this span, e.g. by highlighting it.
1353         Message         -- The error message
1354
1355 data PState = PState {
1356         buffer     :: StringBuffer,
1357     dflags     :: DynFlags,
1358     messages   :: Messages,
1359         last_loc   :: SrcSpan,  -- pos of previous token
1360         last_offs  :: !Int,     -- offset of the previous token from the
1361                                 -- beginning of  the current line.
1362                                 -- \t is equal to 8 spaces.
1363         last_len   :: !Int,     -- len of previous token
1364   last_line_len :: !Int,
1365         loc        :: SrcLoc,   -- current loc (end of prev token + 1)
1366         extsBitmap :: !Int,     -- bitmap that determines permitted extensions
1367         context    :: [LayoutContext],
1368         lex_state  :: [Int]
1369      }
1370         -- last_loc and last_len are used when generating error messages,
1371         -- and in pushCurrentContext only.  Sigh, if only Happy passed the
1372         -- current token to happyError, we could at least get rid of last_len.
1373         -- Getting rid of last_loc would require finding another way to
1374         -- implement pushCurrentContext (which is only called from one place).
1375
1376 newtype P a = P { unP :: PState -> ParseResult a }
1377
1378 instance Monad P where
1379   return = returnP
1380   (>>=) = thenP
1381   fail = failP
1382
1383 returnP :: a -> P a
1384 returnP a = P $ \s -> POk s a
1385
1386 thenP :: P a -> (a -> P b) -> P b
1387 (P m) `thenP` k = P $ \ s ->
1388         case m s of
1389                 POk s1 a         -> (unP (k a)) s1
1390                 PFailed span err -> PFailed span err
1391
1392 failP :: String -> P a
1393 failP msg = P $ \s -> PFailed (last_loc s) (text msg)
1394
1395 failMsgP :: String -> P a
1396 failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
1397
1398 failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
1399 failLocMsgP loc1 loc2 str = P $ \s -> PFailed (mkSrcSpan loc1 loc2) (text str)
1400
1401 failSpanMsgP :: SrcSpan -> String -> P a
1402 failSpanMsgP span msg = P $ \s -> PFailed span (text msg)
1403
1404 extension :: (Int -> Bool) -> P Bool
1405 extension p = P $ \s -> POk s (p $! extsBitmap s)
1406
1407 getExts :: P Int
1408 getExts = P $ \s -> POk s (extsBitmap s)
1409
1410 setSrcLoc :: SrcLoc -> P ()
1411 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
1412
1413 getSrcLoc :: P SrcLoc
1414 getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
1415
1416 setLastToken :: SrcSpan -> Int -> Int -> P ()
1417 setLastToken loc len line_len = P $ \s -> POk s {
1418   last_loc=loc,
1419   last_len=len,
1420   last_line_len=line_len
1421 } ()
1422
1423 data AlexInput = AI SrcLoc {-#UNPACK#-}!Int StringBuffer
1424
1425 alexInputPrevChar :: AlexInput -> Char
1426 alexInputPrevChar (AI _ _ buf) = prevChar buf '\n'
1427
1428 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
1429 alexGetChar (AI loc ofs s)
1430   | atEnd s   = Nothing
1431   | otherwise = adj_c `seq` loc' `seq` ofs' `seq` s' `seq`
1432                 --trace (show (ord c)) $
1433                 Just (adj_c, (AI loc' ofs' s'))
1434   where (c,s') = nextChar s
1435         loc'   = advanceSrcLoc loc c
1436         ofs'   = advanceOffs c ofs
1437
1438         non_graphic     = '\x0'
1439         upper           = '\x1'
1440         lower           = '\x2'
1441         digit           = '\x3'
1442         symbol          = '\x4'
1443         space           = '\x5'
1444         other_graphic   = '\x6'
1445
1446         adj_c
1447           | c <= '\x06' = non_graphic
1448           | c <= '\xff' = c
1449           -- Alex doesn't handle Unicode, so when Unicode
1450           -- character is encoutered we output these values
1451           -- with the actual character value hidden in the state.
1452           | otherwise =
1453                 case generalCategory c of
1454                   UppercaseLetter       -> upper
1455                   LowercaseLetter       -> lower
1456                   TitlecaseLetter       -> upper
1457                   ModifierLetter        -> other_graphic
1458                   OtherLetter           -> other_graphic
1459                   NonSpacingMark        -> other_graphic
1460                   SpacingCombiningMark  -> other_graphic
1461                   EnclosingMark         -> other_graphic
1462                   DecimalNumber         -> digit
1463                   LetterNumber          -> other_graphic
1464                   OtherNumber           -> other_graphic
1465                   ConnectorPunctuation  -> other_graphic
1466                   DashPunctuation       -> other_graphic
1467                   OpenPunctuation       -> other_graphic
1468                   ClosePunctuation      -> other_graphic
1469                   InitialQuote          -> other_graphic
1470                   FinalQuote            -> other_graphic
1471                   OtherPunctuation      -> other_graphic
1472                   MathSymbol            -> symbol
1473                   CurrencySymbol        -> symbol
1474                   ModifierSymbol        -> symbol
1475                   OtherSymbol           -> symbol
1476                   Space                 -> space
1477                   _other                -> non_graphic
1478
1479 -- This version does not squash unicode characters, it is used when
1480 -- lexing strings.
1481 alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
1482 alexGetChar' (AI loc ofs s)
1483   | atEnd s   = Nothing
1484   | otherwise = c `seq` loc' `seq` ofs' `seq` s' `seq`
1485                 --trace (show (ord c)) $
1486                 Just (c, (AI loc' ofs' s'))
1487   where (c,s') = nextChar s
1488         loc'   = advanceSrcLoc loc c
1489         ofs'   = advanceOffs c ofs
1490
1491 advanceOffs :: Char -> Int -> Int
1492 advanceOffs '\n' offs = 0
1493 advanceOffs '\t' offs = (offs `quot` 8 + 1) * 8
1494 advanceOffs _    offs = offs + 1
1495
1496 getInput :: P AlexInput
1497 getInput = P $ \s@PState{ loc=l, last_offs=o, buffer=b } -> POk s (AI l o b)
1498
1499 setInput :: AlexInput -> P ()
1500 setInput (AI l o b) = P $ \s -> POk s{ loc=l, last_offs=o, buffer=b } ()
1501
1502 pushLexState :: Int -> P ()
1503 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
1504
1505 popLexState :: P Int
1506 popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
1507
1508 getLexState :: P Int
1509 getLexState = P $ \s@PState{ lex_state=ls:l } -> POk s ls
1510
1511 -- for reasons of efficiency, flags indicating language extensions (eg,
1512 -- -fglasgow-exts or -fparr) are represented by a bitmap stored in an unboxed
1513 -- integer
1514
1515 genericsBit, ffiBit, parrBit :: Int
1516 genericsBit = 0 -- {| and |}
1517 ffiBit     = 1
1518 parrBit    = 2
1519 arrowsBit  = 4
1520 thBit      = 5
1521 ipBit      = 6
1522 explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
1523 bangPatBit = 8  -- Tells the parser to understand bang-patterns
1524                 -- (doesn't affect the lexer)
1525 tyFamBit   = 9  -- indexed type families: 'family' keyword and kind sigs
1526 haddockBit = 10 -- Lex and parse Haddock comments
1527 magicHashBit = 11 -- # in both functions and operators
1528 kindSigsBit = 12 -- Kind signatures on type variables
1529 recursiveDoBit = 13 -- mdo
1530 unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
1531 unboxedTuplesBit = 15 -- (# and #)
1532 standaloneDerivingBit = 16 -- standalone instance deriving declarations
1533
1534 genericsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
1535 always           _     = True
1536 genericsEnabled  flags = testBit flags genericsBit
1537 ffiEnabled       flags = testBit flags ffiBit
1538 parrEnabled      flags = testBit flags parrBit
1539 arrowsEnabled    flags = testBit flags arrowsBit
1540 thEnabled        flags = testBit flags thBit
1541 ipEnabled        flags = testBit flags ipBit
1542 explicitForallEnabled flags = testBit flags explicitForallBit
1543 bangPatEnabled   flags = testBit flags bangPatBit
1544 tyFamEnabled     flags = testBit flags tyFamBit
1545 haddockEnabled   flags = testBit flags haddockBit
1546 magicHashEnabled flags = testBit flags magicHashBit
1547 kindSigsEnabled  flags = testBit flags kindSigsBit
1548 recursiveDoEnabled flags = testBit flags recursiveDoBit
1549 unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
1550 unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
1551 standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit
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, 0]
1590         -- we begin in the layout state if toplev_layout is set
1591     }
1592     where
1593       bitmap = genericsBit `setBitIf` dopt Opt_Generics 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                .|. explicitForallBit `setBitIf` dopt Opt_Rank2Types flags
1603                .|. explicitForallBit `setBitIf` dopt Opt_RankNTypes flags
1604                .|. bangPatBit   `setBitIf` dopt Opt_BangPatterns flags
1605                .|. tyFamBit     `setBitIf` dopt Opt_TypeFamilies flags
1606                .|. haddockBit   `setBitIf` dopt Opt_Haddock      flags
1607                .|. magicHashBit `setBitIf` dopt Opt_MagicHash    flags
1608                .|. kindSigsBit  `setBitIf` dopt Opt_KindSignatures flags
1609                .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
1610                .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
1611                .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
1612                .|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving 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 }