compiler/parser/Lexer.x

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