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