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