compiler/parser/Lexer.x

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