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 --    - parsing integers is a bit slow
  16 --    - readRational is a bit slow
  17 --
  18 --   Known bugs, that were also in the previous version:
  19 --    - M... should be 3 tokens, not 1.
  20 --    - pragma-end should be only valid in a pragma
  21
  22 --   qualified operator NOTES.
  23 --
  24 --   - If M.(+) is a single lexeme, then..
  25 --     - Probably (+) should be a single lexeme too, for consistency.
  26 --       Otherwise ( + ) would be a prefix operator, but M.( + ) would not be.
  27 --     - But we have to rule out reserved operators, otherwise (..) becomes
  28 --       a different lexeme.
  29 --     - Should we therefore also rule out reserved operators in the qualified
  30 --       form?  This is quite difficult to achieve.  We don't do it for
  31 --       qualified varids.
  32
  33 {
  34 -- XXX The above flags turn off warnings in the generated code:
  35 {-# LANGUAGE BangPatterns #-}
  36 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
  37 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
  38 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
  39 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
  40 -- But alex still generates some code that causes the "lazy unlifted bindings"
  41 -- warning, and old compilers don't know about it so we can't easily turn
  42 -- it off, so for now we use the sledge hammer:
  43 {-# OPTIONS_GHC -w #-}
  44
  45 {-# OPTIONS_GHC -funbox-strict-fields #-}
  46
  47 module Lexer (
  48    Token(..), lexer, pragState, mkPState, PState(..),
  49    P(..), ParseResult(..), getSrcLoc,
  50    getPState, getDynFlags, withThisPackage,
  51    failLocMsgP, failSpanMsgP, srcParseFail,
  52    getMessages,
  53    popContext, pushCurrentContext, setLastToken, setSrcLoc,
  54    activeContext, nextIsEOF,
  55    getLexState, popLexState, pushLexState,
  56    extension, bangPatEnabled, datatypeContextsEnabled,
  57    addWarning,
  58    lexTokenStream
  59   ) where
  60
  61 import Bag
  62 import ErrUtils
  63 import Outputable
  64 import StringBuffer
  65 import FastString
  66 import SrcLoc
  67 import UniqFM
  68 import DynFlags
  69 import Module
  70 import Ctype
  71 import BasicTypes       ( InlineSpec(..), RuleMatchInfo(..) )
  72 import Util             ( readRational )
  73
  74 import Control.Monad
  75 import Data.Bits
  76 import Data.Char
  77 import Data.List
  78 import Data.Maybe
  79 import Data.Map (Map)
  80 import qualified Data.Map as Map
  81 import Data.Ratio
  82 }
  83
  84 $unispace    = \x05 -- Trick Alex into handling Unicode. See alexGetChar.
  85 $whitechar   = [\ \n\r\f\v $unispace]
  86 $white_no_nl = $whitechar # \n
  87 $tab         = \t
  88
  89 $ascdigit  = 0-9
  90 $unidigit  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
  91 $decdigit  = $ascdigit -- for now, should really be $digit (ToDo)
  92 $digit     = [$ascdigit $unidigit]
  93
  94 $special   = [\(\)\,\;\[\]\`\{\}]
  95 $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
  96 $unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
  97 $symbol    = [$ascsymbol $unisymbol] # [$special \_\:\"\']
  98
  99 $unilarge  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
 100 $asclarge  = [A-Z]
 101 $large     = [$asclarge $unilarge]
 102
 103 $unismall  = \x02 -- Trick Alex into handling Unicode. See alexGetChar.
 104 $ascsmall  = [a-z]
 105 $small     = [$ascsmall $unismall \_]
 106
 107 $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar.
 108 $graphic   = [$small $large $symbol $digit $special $unigraphic \:\"\']
 109
 110 $octit     = 0-7
 111 $hexit     = [$decdigit A-F a-f]
 112 $symchar   = [$symbol \:]
 113 $nl        = [\n\r]
 114 $idchar    = [$small $large $digit \']
 115
 116 $pragmachar = [$small $large $digit]
 117
 118 $docsym    = [\| \^ \* \$]
 119
 120 @varid     = $small $idchar*
 121 @conid     = $large $idchar*
 122
 123 @varsym    = $symbol $symchar*
 124 @consym    = \: $symchar*
 125
 126 @decimal     = $decdigit+
 127 @octal       = $octit+
 128 @hexadecimal = $hexit+
 129 @exponent    = [eE] [\-\+]? @decimal
 130
 131 -- we support the hierarchical module name extension:
 132 @qual = (@conid \.)+
 133
 134 @floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
 135
 136 -- normal signed numerical literals can only be explicitly negative,
 137 -- not explicitly positive (contrast @exponent)
 138 @negative = \-
 139 @signed = @negative ?
 140
 141 haskell :-
 142
 143 -- everywhere: skip whitespace and comments
 144 $white_no_nl+                           ;
 145 $tab+         { warn Opt_WarnTabs (text "Warning: Tab character") }
 146
 147 -- Everywhere: deal with nested comments.  We explicitly rule out
 148 -- pragmas, "{-#", so that we don't accidentally treat them as comments.
 149 -- (this can happen even though pragmas will normally take precedence due to
 150 -- longest-match, because pragmas aren't valid in every state, but comments
 151 -- are). We also rule out nested Haddock comments, if the -haddock flag is
 152 -- set.
 153
 154 "{-" / { isNormalComment } { nested_comment lexToken }
 155
 156 -- Single-line comments are a bit tricky.  Haskell 98 says that two or
 157 -- more dashes followed by a symbol should be parsed as a varsym, so we
 158 -- have to exclude those.
 159
 160 -- Since Haddock comments aren't valid in every state, we need to rule them
 161 -- out here.
 162
 163 -- The following two rules match comments that begin with two dashes, but
 164 -- continue with a different character. The rules test that this character
 165 -- is not a symbol (in which case we'd have a varsym), and that it's not a
 166 -- space followed by a Haddock comment symbol (docsym) (in which case we'd
 167 -- have a Haddock comment). The rules then munch the rest of the line.
 168
 169 "-- " ~[$docsym \#] .* { lineCommentToken }
 170 "--" [^$symbol : \ ] .* { lineCommentToken }
 171
 172 -- Next, match Haddock comments if no -haddock flag
 173
 174 "-- " [$docsym \#] .* / { ifExtension (not . haddockEnabled) } { lineCommentToken }
 175
 176 -- Now, when we've matched comments that begin with 2 dashes and continue
 177 -- with a different character, we need to match comments that begin with three
 178 -- or more dashes (which clearly can't be Haddock comments). We only need to
 179 -- make sure that the first non-dash character isn't a symbol, and munch the
 180 -- rest of the line.
 181
 182 "---"\-* [^$symbol :] .* { lineCommentToken }
 183
 184 -- Since the previous rules all match dashes followed by at least one
 185 -- character, we also need to match a whole line filled with just dashes.
 186
 187 "--"\-* / { atEOL } { lineCommentToken }
 188
 189 -- We need this rule since none of the other single line comment rules
 190 -- actually match this case.
 191
 192 "-- " / { atEOL } { lineCommentToken }
 193
 194 -- 'bol' state: beginning of a line.  Slurp up all the whitespace (including
 195 -- blank lines) until we find a non-whitespace character, then do layout
 196 -- processing.
 197 --
 198 -- One slight wibble here: what if the line begins with {-#? In
 199 -- theory, we have to lex the pragma to see if it's one we recognise,
 200 -- and if it is, then we backtrack and do_bol, otherwise we treat it
 201 -- as a nested comment.  We don't bother with this: if the line begins
 202 -- with {-#, then we'll assume it's a pragma we know about and go for do_bol.
 203 <bol> {
 204   \n                                    ;
 205   ^\# (line)?                           { begin line_prag1 }
 206   ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently
 207   ^\# \! .* \n                          ; -- #!, for scripts
 208   ()                                    { do_bol }
 209 }
 210
 211 -- after a layout keyword (let, where, do, of), we begin a new layout
 212 -- context if the curly brace is missing.
 213 -- Careful! This stuff is quite delicate.
 214 <layout, layout_do> {
 215   \{ / { notFollowedBy '-' }            { hopefully_open_brace }
 216         -- we might encounter {-# here, but {- has been handled already
 217   \n                                    ;
 218   ^\# (line)?                           { begin line_prag1 }
 219 }
 220
 221 -- do is treated in a subtly different way, see new_layout_context
 222 <layout>    ()                          { new_layout_context True }
 223 <layout_do> ()                          { new_layout_context False }
 224
 225 -- after a new layout context which was found to be to the left of the
 226 -- previous context, we have generated a '{' token, and we now need to
 227 -- generate a matching '}' token.
 228 <layout_left>  ()                       { do_layout_left }
 229
 230 <0,option_prags> \n                             { begin bol }
 231
 232 "{-#" $whitechar* $pragmachar+ / { known_pragma linePrags }
 233                                 { dispatch_pragmas linePrags }
 234
 235 -- single-line line pragmas, of the form
 236 --    # <line> "<file>" <extra-stuff> \n
 237 <line_prag1> $decdigit+                 { setLine line_prag1a }
 238 <line_prag1a> \" [$graphic \ ]* \"      { setFile line_prag1b }
 239 <line_prag1b> .*                        { pop }
 240
 241 -- Haskell-style line pragmas, of the form
 242 --    {-# LINE <line> "<file>" #-}
 243 <line_prag2> $decdigit+                 { setLine line_prag2a }
 244 <line_prag2a> \" [$graphic \ ]* \"      { setFile line_prag2b }
 245 <line_prag2b> "#-}"|"-}"                { pop }
 246    -- NOTE: accept -} at the end of a LINE pragma, for compatibility
 247    -- with older versions of GHC which generated these.
 248
 249 <0,option_prags> {
 250   "{-#" $whitechar* $pragmachar+
 251         $whitechar+ $pragmachar+ / { known_pragma twoWordPrags }
 252                                  { dispatch_pragmas twoWordPrags }
 253
 254   "{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags }
 255                                  { dispatch_pragmas oneWordPrags }
 256
 257   -- We ignore all these pragmas, but don't generate a warning for them
 258   "{-#" $whitechar* $pragmachar+ / { known_pragma ignoredPrags }
 259                                  { dispatch_pragmas ignoredPrags }
 260
 261   -- ToDo: should only be valid inside a pragma:
 262   "#-}"                                 { endPrag }
 263 }
 264
 265 <option_prags> {
 266   "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }
 267                                    { dispatch_pragmas fileHeaderPrags }
 268
 269   "-- #"                                 { multiline_doc_comment }
 270 }
 271
 272 <0> {
 273   -- In the "0" mode we ignore these pragmas
 274   "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }
 275                      { nested_comment lexToken }
 276 }
 277
 278 <0> {
 279   "-- #" .* { lineCommentToken }
 280 }
 281
 282 <0,option_prags> {
 283   "{-#"  { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma")
 284                     (nested_comment lexToken) }
 285 }
 286
 287 -- '0' state: ordinary lexemes
 288
 289 -- Haddock comments
 290
 291 <0,option_prags> {
 292   "-- " $docsym      / { ifExtension haddockEnabled } { multiline_doc_comment }
 293   "{-" \ ? $docsym   / { ifExtension haddockEnabled } { nested_doc_comment }
 294 }
 295
 296 -- "special" symbols
 297
 298 <0> {
 299   "[:" / { ifExtension parrEnabled }    { token ITopabrack }
 300   ":]" / { ifExtension parrEnabled }    { token ITcpabrack }
 301 }
 302
 303 <0> {
 304   "[|"      / { ifExtension thEnabled } { token ITopenExpQuote }
 305   "[e|"     / { ifExtension thEnabled } { token ITopenExpQuote }
 306   "[p|"     / { ifExtension thEnabled } { token ITopenPatQuote }
 307   "[d|"     / { ifExtension thEnabled } { layout_token ITopenDecQuote }
 308   "[t|"     / { ifExtension thEnabled } { token ITopenTypQuote }
 309   "|]"      / { ifExtension thEnabled } { token ITcloseQuote }
 310   \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
 311   "$("      / { ifExtension thEnabled } { token ITparenEscape }
 312
 313 -- For backward compatibility, accept the old dollar syntax
 314   "[$" @varid "|"  / { ifExtension qqEnabled }
 315                      { lex_quasiquote_tok }
 316
 317   "[" @varid "|"  / { ifExtension qqEnabled }
 318                      { lex_quasiquote_tok }
 319 }
 320
 321 <0> {
 322   "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
 323                                         { special IToparenbar }
 324   "|)" / { ifExtension arrowsEnabled }  { special ITcparenbar }
 325 }
 326
 327 <0> {
 328   \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
 329 }
 330
 331 <0> {
 332   "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol }
 333          { token IToubxparen }
 334   "#)" / { ifExtension unboxedTuplesEnabled }
 335          { token ITcubxparen }
 336 }
 337
 338 <0> {
 339   "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
 340   "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
 341 }
 342
 343 <0,option_prags> {
 344   \(                                    { special IToparen }
 345   \)                                    { special ITcparen }
 346   \[                                    { special ITobrack }
 347   \]                                    { special ITcbrack }
 348   \,                                    { special ITcomma }
 349   \;                                    { special ITsemi }
 350   \`                                    { special ITbackquote }
 351
 352   \{                                    { open_brace }
 353   \}                                    { close_brace }
 354 }
 355
 356 <0,option_prags> {
 357   @qual @varid                  { idtoken qvarid }
 358   @qual @conid                  { idtoken qconid }
 359   @varid                        { varid }
 360   @conid                        { idtoken conid }
 361 }
 362
 363 <0> {
 364   @qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
 365   @qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
 366   @varid "#"+       / { ifExtension magicHashEnabled } { varid }
 367   @conid "#"+       / { ifExtension magicHashEnabled } { idtoken conid }
 368 }
 369
 370 -- ToDo: - move `var` and (sym) into lexical syntax?
 371 --       - remove backquote from $special?
 372 <0> {
 373   @qual @varsym                                    { idtoken qvarsym }
 374   @qual @consym                                    { idtoken qconsym }
 375   @varsym                                          { varsym }
 376   @consym                                          { consym }
 377 }
 378
 379 -- For the normal boxed literals we need to be careful
 380 -- when trying to be close to Haskell98
 381 <0> {
 382   -- Normal integral literals (:: Num a => a, from Integer)
 383   @decimal           { tok_num positive 0 0 decimal }
 384   0[oO] @octal       { tok_num positive 2 2 octal }
 385   0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal }
 386
 387   -- Normal rational literals (:: Fractional a => a, from Rational)
 388   @floating_point    { strtoken tok_float }
 389 }
 390
 391 <0> {
 392   -- Unboxed ints (:: Int#) and words (:: Word#)
 393   -- It's simpler (and faster?) to give separate cases to the negatives,
 394   -- especially considering octal/hexadecimal prefixes.
 395   @decimal                     \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
 396   0[oO] @octal                 \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
 397   0[xX] @hexadecimal           \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
 398   @negative @decimal           \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
 399   @negative 0[oO] @octal       \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
 400   @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
 401
 402   @decimal                     \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal }
 403   0[oO] @octal                 \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }
 404   0[xX] @hexadecimal           \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }
 405
 406   -- Unboxed floats and doubles (:: Float#, :: Double#)
 407   -- prim_{float,double} work with signed literals
 408   @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }
 409   @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble }
 410 }
 411
 412 -- Strings and chars are lexed by hand-written code.  The reason is
 413 -- that even if we recognise the string or char here in the regex
 414 -- lexer, we would still have to parse the string afterward in order
 415 -- to convert it to a String.
 416 <0> {
 417   \'                            { lex_char_tok }
 418   \"                            { lex_string_tok }
 419 }
 420
 421 {
 422 -- -----------------------------------------------------------------------------
 423 -- The token type
 424
 425 data Token
 426   = ITas                        -- Haskell keywords
 427   | ITcase
 428   | ITclass
 429   | ITdata
 430   | ITdefault
 431   | ITderiving
 432   | ITdo
 433   | ITelse
 434   | IThiding
 435   | ITif
 436   | ITimport
 437   | ITin
 438   | ITinfix
 439   | ITinfixl
 440   | ITinfixr
 441   | ITinstance
 442   | ITlet
 443   | ITmodule
 444   | ITnewtype
 445   | ITof
 446   | ITqualified
 447   | ITthen
 448   | ITtype
 449   | ITwhere
 450   | ITscc                       -- ToDo: remove (we use {-# SCC "..." #-} now)
 451
 452   | ITforall                    -- GHC extension keywords
 453   | ITforeign
 454   | ITexport
 455   | ITlabel
 456   | ITdynamic
 457   | ITsafe
 458   | ITthreadsafe
 459   | ITinterruptible
 460   | ITunsafe
 461   | ITstdcallconv
 462   | ITccallconv
 463   | ITprimcallconv
 464   | ITmdo
 465   | ITfamily
 466   | ITgroup
 467   | ITby
 468   | ITusing
 469
 470         -- Pragmas
 471   | ITinline_prag InlineSpec RuleMatchInfo
 472   | ITspec_prag                 -- SPECIALISE
 473   | ITspec_inline_prag Bool     -- SPECIALISE INLINE (or NOINLINE)
 474   | ITsource_prag
 475   | ITrules_prag
 476   | ITwarning_prag
 477   | ITdeprecated_prag
 478   | ITline_prag
 479   | ITscc_prag
 480   | ITgenerated_prag
 481   | ITcore_prag                 -- hdaume: core annotations
 482   | ITunpack_prag
 483   | ITann_prag
 484   | ITclose_prag
 485   | IToptions_prag String
 486   | ITinclude_prag String
 487   | ITlanguage_prag
 488   | ITvect_prag
 489   | ITvect_scalar_prag
 490
 491   | ITdotdot                    -- reserved symbols
 492   | ITcolon
 493   | ITdcolon
 494   | ITequal
 495   | ITlam
 496   | ITvbar
 497   | ITlarrow
 498   | ITrarrow
 499   | ITat
 500   | ITtilde
 501   | ITdarrow
 502   | ITminus
 503   | ITbang
 504   | ITstar
 505   | ITdot
 506
 507   | ITbiglam                    -- GHC-extension symbols
 508
 509   | ITocurly                    -- special symbols
 510   | ITccurly
 511   | ITocurlybar                 -- {|, for type applications
 512   | ITccurlybar                 -- |}, for type applications
 513   | ITvocurly
 514   | ITvccurly
 515   | ITobrack
 516   | ITopabrack                  -- [:, for parallel arrays with -XParallelArrays
 517   | ITcpabrack                  -- :], for parallel arrays with -XParallelArrays
 518   | ITcbrack
 519   | IToparen
 520   | ITcparen
 521   | IToubxparen
 522   | ITcubxparen
 523   | ITsemi
 524   | ITcomma
 525   | ITunderscore
 526   | ITbackquote
 527
 528   | ITvarid   FastString        -- identifiers
 529   | ITconid   FastString
 530   | ITvarsym  FastString
 531   | ITconsym  FastString
 532   | ITqvarid  (FastString,FastString)
 533   | ITqconid  (FastString,FastString)
 534   | ITqvarsym (FastString,FastString)
 535   | ITqconsym (FastString,FastString)
 536   | ITprefixqvarsym (FastString,FastString)
 537   | ITprefixqconsym (FastString,FastString)
 538
 539   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
 540
 541   | ITchar       Char
 542   | ITstring     FastString
 543   | ITinteger    Integer
 544   | ITrational   Rational
 545
 546   | ITprimchar   Char
 547   | ITprimstring FastString
 548   | ITprimint    Integer
 549   | ITprimword   Integer
 550   | ITprimfloat  Rational
 551   | ITprimdouble Rational
 552
 553   -- Template Haskell extension tokens
 554   | ITopenExpQuote              --  [| or [e|
 555   | ITopenPatQuote              --  [p|
 556   | ITopenDecQuote              --  [d|
 557   | ITopenTypQuote              --  [t|
 558   | ITcloseQuote                --  |]
 559   | ITidEscape   FastString     --  $x
 560   | ITparenEscape               --  $(
 561   | ITvarQuote                  --  '
 562   | ITtyQuote                   --  ''
 563   | ITquasiQuote (FastString,FastString,SrcSpan) --  [:...|...|]
 564
 565   -- Arrow notation extension
 566   | ITproc
 567   | ITrec
 568   | IToparenbar                 --  (|
 569   | ITcparenbar                 --  |)
 570   | ITlarrowtail                --  -<
 571   | ITrarrowtail                --  >-
 572   | ITLarrowtail                --  -<<
 573   | ITRarrowtail                --  >>-
 574
 575   | ITunknown String            -- Used when the lexer can't make sense of it
 576   | ITeof                       -- end of file token
 577
 578   -- Documentation annotations
 579   | ITdocCommentNext  String     -- something beginning '-- |'
 580   | ITdocCommentPrev  String     -- something beginning '-- ^'
 581   | ITdocCommentNamed String     -- something beginning '-- $'
 582   | ITdocSection      Int String -- a section heading
 583   | ITdocOptions      String     -- doc options (prune, ignore-exports, etc)
 584   | ITdocOptionsOld   String     -- doc options declared "-- # ..."-style
 585   | ITlineComment     String     -- comment starting by "--"
 586   | ITblockComment    String     -- comment in {- -}
 587
 588 #ifdef DEBUG
 589   deriving Show -- debugging
 590 #endif
 591
 592 {-
 593 isSpecial :: Token -> Bool
 594 -- If we see M.x, where x is a keyword, but
 595 -- is special, we treat is as just plain M.x,
 596 -- not as a keyword.
 597 isSpecial ITas          = True
 598 isSpecial IThiding      = True
 599 isSpecial ITqualified   = True
 600 isSpecial ITforall      = True
 601 isSpecial ITexport      = True
 602 isSpecial ITlabel       = True
 603 isSpecial ITdynamic     = True
 604 isSpecial ITsafe        = True
 605 isSpecial ITthreadsafe  = True
 606 isSpecial ITinterruptible = True
 607 isSpecial ITunsafe      = True
 608 isSpecial ITccallconv   = True
 609 isSpecial ITstdcallconv = True
 610 isSpecial ITprimcallconv = True
 611 isSpecial ITmdo         = True
 612 isSpecial ITfamily      = True
 613 isSpecial ITgroup   = True
 614 isSpecial ITby      = True
 615 isSpecial ITusing   = True
 616 isSpecial _             = False
 617 -}
 618
 619 -- the bitmap provided as the third component indicates whether the
 620 -- corresponding extension keyword is valid under the extension options
 621 -- provided to the compiler; if the extension corresponding to *any* of the
 622 -- bits set in the bitmap is enabled, the keyword is valid (this setup
 623 -- facilitates using a keyword in two different extensions that can be
 624 -- activated independently)
 625 --
 626 reservedWordsFM :: UniqFM (Token, Int)
 627 reservedWordsFM = listToUFM $
 628         map (\(x, y, z) -> (mkFastString x, (y, z)))
 629        [( "_",          ITunderscore,   0 ),
 630         ( "as",         ITas,           0 ),
 631         ( "case",       ITcase,         0 ),
 632         ( "class",      ITclass,        0 ),
 633         ( "data",       ITdata,         0 ),
 634         ( "default",    ITdefault,      0 ),
 635         ( "deriving",   ITderiving,     0 ),
 636         ( "do",         ITdo,           0 ),
 637         ( "else",       ITelse,         0 ),
 638         ( "hiding",     IThiding,       0 ),
 639         ( "if",         ITif,           0 ),
 640         ( "import",     ITimport,       0 ),
 641         ( "in",         ITin,           0 ),
 642         ( "infix",      ITinfix,        0 ),
 643         ( "infixl",     ITinfixl,       0 ),
 644         ( "infixr",     ITinfixr,       0 ),
 645         ( "instance",   ITinstance,     0 ),
 646         ( "let",        ITlet,          0 ),
 647         ( "module",     ITmodule,       0 ),
 648         ( "newtype",    ITnewtype,      0 ),
 649         ( "of",         ITof,           0 ),
 650         ( "qualified",  ITqualified,    0 ),
 651         ( "then",       ITthen,         0 ),
 652         ( "type",       ITtype,         0 ),
 653         ( "where",      ITwhere,        0 ),
 654         ( "_scc_",      ITscc,          0 ),            -- ToDo: remove
 655
 656     ( "forall", ITforall,        bit explicitForallBit .|. bit inRulePragBit),
 657         ( "mdo",        ITmdo,           bit recursiveDoBit),
 658         ( "family",     ITfamily,        bit tyFamBit),
 659     ( "group",  ITgroup,     bit transformComprehensionsBit),
 660     ( "by",     ITby,        bit transformComprehensionsBit),
 661     ( "using",  ITusing,     bit transformComprehensionsBit),
 662
 663         ( "foreign",    ITforeign,       bit ffiBit),
 664         ( "export",     ITexport,        bit ffiBit),
 665         ( "label",      ITlabel,         bit ffiBit),
 666         ( "dynamic",    ITdynamic,       bit ffiBit),
 667         ( "safe",       ITsafe,          bit ffiBit),
 668         ( "threadsafe", ITthreadsafe,    bit ffiBit),  -- ToDo: remove
 669         ( "interruptible", ITinterruptible, bit ffiBit),
 670         ( "unsafe",     ITunsafe,        bit ffiBit),
 671         ( "stdcall",    ITstdcallconv,   bit ffiBit),
 672         ( "ccall",      ITccallconv,     bit ffiBit),
 673         ( "prim",       ITprimcallconv,  bit ffiBit),
 674
 675         ( "rec",        ITrec,           bit recBit),
 676         ( "proc",       ITproc,          bit arrowsBit)
 677      ]
 678
 679 reservedSymsFM :: UniqFM (Token, Int -> Bool)
 680 reservedSymsFM = listToUFM $
 681     map (\ (x,y,z) -> (mkFastString x,(y,z)))
 682       [ ("..",  ITdotdot,   always)
 683         -- (:) is a reserved op, meaning only list cons
 684        ,(":",   ITcolon,    always)
 685        ,("::",  ITdcolon,   always)
 686        ,("=",   ITequal,    always)
 687        ,("\\",  ITlam,      always)
 688        ,("|",   ITvbar,     always)
 689        ,("<-",  ITlarrow,   always)
 690        ,("->",  ITrarrow,   always)
 691        ,("@",   ITat,       always)
 692        ,("~",   ITtilde,    always)
 693        ,("=>",  ITdarrow,   always)
 694        ,("-",   ITminus,    always)
 695        ,("!",   ITbang,     always)
 696
 697         -- For data T (a::*) = MkT
 698        ,("*", ITstar, always) -- \i -> kindSigsEnabled i || tyFamEnabled i)
 699         -- For 'forall a . t'
 700        ,(".", ITdot,  always) -- \i -> explicitForallEnabled i || inRulePrag i)
 701
 702        ,("-<",  ITlarrowtail, arrowsEnabled)
 703        ,(">-",  ITrarrowtail, arrowsEnabled)
 704        ,("-<<", ITLarrowtail, arrowsEnabled)
 705        ,(">>-", ITRarrowtail, arrowsEnabled)
 706
 707        ,("∷",   ITdcolon, unicodeSyntaxEnabled)
 708        ,("⇒",   ITdarrow, unicodeSyntaxEnabled)
 709        ,("∀",   ITforall, \i -> unicodeSyntaxEnabled i &&
 710                                 explicitForallEnabled i)
 711        ,("→",   ITrarrow, unicodeSyntaxEnabled)
 712        ,("←",   ITlarrow, unicodeSyntaxEnabled)
 713
 714        ,("⤙",   ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
 715        ,("⤚",   ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
 716        ,("⤛",   ITLarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
 717        ,("⤜",   ITRarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
 718
 719        ,("★", ITstar, unicodeSyntaxEnabled)
 720
 721         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
 722         -- form part of a large operator.  This would let us have a better
 723         -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
 724        ]
 725
 726 -- -----------------------------------------------------------------------------
 727 -- Lexer actions
 728
 729 type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
 730
 731 special :: Token -> Action
 732 special tok span _buf _len = return (L span tok)
 733
 734 token, layout_token :: Token -> Action
 735 token t span _buf _len = return (L span t)
 736 layout_token t span _buf _len = pushLexState layout >> return (L span t)
 737
 738 idtoken :: (StringBuffer -> Int -> Token) -> Action
 739 idtoken f span buf len = return (L span $! (f buf len))
 740
 741 skip_one_varid :: (FastString -> Token) -> Action
 742 skip_one_varid f span buf len
 743   = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
 744
 745 strtoken :: (String -> Token) -> Action
 746 strtoken f span buf len =
 747   return (L span $! (f $! lexemeToString buf len))
 748
 749 init_strtoken :: Int -> (String -> Token) -> Action
 750 -- like strtoken, but drops the last N character(s)
 751 init_strtoken drop f span buf len =
 752   return (L span $! (f $! lexemeToString buf (len-drop)))
 753
 754 begin :: Int -> Action
 755 begin code _span _str _len = do pushLexState code; lexToken
 756
 757 pop :: Action
 758 pop _span _buf _len = do _ <- popLexState
 759                          lexToken
 760
 761 hopefully_open_brace :: Action
 762 hopefully_open_brace span buf len
 763  = do relaxed <- extension relaxedLayout
 764       ctx <- getContext
 765       (AI l _) <- getInput
 766       let offset = srcLocCol l
 767           isOK = relaxed ||
 768                  case ctx of
 769                  Layout prev_off : _ -> prev_off < offset
 770                  _                   -> True
 771       if isOK then pop_and open_brace span buf len
 772               else failSpanMsgP span (text "Missing block")
 773
 774 pop_and :: Action -> Action
 775 pop_and act span buf len = do _ <- popLexState
 776                               act span buf len
 777
 778 {-# INLINE nextCharIs #-}
 779 nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool
 780 nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
 781
 782 notFollowedBy :: Char -> AlexAccPred Int
 783 notFollowedBy char _ _ _ (AI _ buf)
 784   = nextCharIs buf (/=char)
 785
 786 notFollowedBySymbol :: AlexAccPred Int
 787 notFollowedBySymbol _ _ _ (AI _ buf)
 788   = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
 789
 790 -- We must reject doc comments as being ordinary comments everywhere.
 791 -- In some cases the doc comment will be selected as the lexeme due to
 792 -- maximal munch, but not always, because the nested comment rule is
 793 -- valid in all states, but the doc-comment rules are only valid in
 794 -- the non-layout states.
 795 isNormalComment :: AlexAccPred Int
 796 isNormalComment bits _ _ (AI _ buf)
 797   | haddockEnabled bits = notFollowedByDocOrPragma
 798   | otherwise           = nextCharIs buf (/='#')
 799   where
 800     notFollowedByDocOrPragma
 801        = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
 802
 803 spaceAndP :: StringBuffer -> (StringBuffer -> Bool) -> Bool
 804 spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
 805
 806 {-
 807 haddockDisabledAnd p bits _ _ (AI _ buf)
 808   = if haddockEnabled bits then False else (p buf)
 809 -}
 810
 811 atEOL :: AlexAccPred Int
 812 atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'
 813
 814 ifExtension :: (Int -> Bool) -> AlexAccPred Int
 815 ifExtension pred bits _ _ _ = pred bits
 816
 817 multiline_doc_comment :: Action
 818 multiline_doc_comment span buf _len = withLexedDocType (worker "")
 819   where
 820     worker commentAcc input docType oneLine = case alexGetChar input of
 821       Just ('\n', input')
 822         | oneLine -> docCommentEnd input commentAcc docType buf span
 823         | otherwise -> case checkIfCommentLine input' of
 824           Just input -> worker ('\n':commentAcc) input docType False
 825           Nothing -> docCommentEnd input commentAcc docType buf span
 826       Just (c, input) -> worker (c:commentAcc) input docType oneLine
 827       Nothing -> docCommentEnd input commentAcc docType buf span
 828
 829     checkIfCommentLine input = check (dropNonNewlineSpace input)
 830       where
 831         check input = case alexGetChar input of
 832           Just ('-', input) -> case alexGetChar input of
 833             Just ('-', input) -> case alexGetChar input of
 834               Just (c, _) | c /= '-' -> Just input
 835               _ -> Nothing
 836             _ -> Nothing
 837           _ -> Nothing
 838
 839         dropNonNewlineSpace input = case alexGetChar input of
 840           Just (c, input')
 841             | isSpace c && c /= '\n' -> dropNonNewlineSpace input'
 842             | otherwise -> input
 843           Nothing -> input
 844
 845 lineCommentToken :: Action
 846 lineCommentToken span buf len = do
 847   b <- extension rawTokenStreamEnabled
 848   if b then strtoken ITlineComment span buf len else lexToken
 849
 850 {-
 851   nested comments require traversing by hand, they can't be parsed
 852   using regular expressions.
 853 -}
 854 nested_comment :: P (Located Token) -> Action
 855 nested_comment cont span _str _len = do
 856   input <- getInput
 857   go "" (1::Int) input
 858   where
 859     go commentAcc 0 input = do setInput input
 860                                b <- extension rawTokenStreamEnabled
 861                                if b
 862                                  then docCommentEnd input commentAcc ITblockComment _str span
 863                                  else cont
 864     go commentAcc n input = case alexGetChar input of
 865       Nothing -> errBrace input span
 866       Just ('-',input) -> case alexGetChar input of
 867         Nothing  -> errBrace input span
 868         Just ('\125',input) -> go commentAcc (n-1) input
 869         Just (_,_)          -> go ('-':commentAcc) n input
 870       Just ('\123',input) -> case alexGetChar input of
 871         Nothing  -> errBrace input span
 872         Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input
 873         Just (_,_)       -> go ('\123':commentAcc) n input
 874       Just (c,input) -> go (c:commentAcc) n input
 875
 876 nested_doc_comment :: Action
 877 nested_doc_comment span buf _len = withLexedDocType (go "")
 878   where
 879     go commentAcc input docType _ = case alexGetChar input of
 880       Nothing -> errBrace input span
 881       Just ('-',input) -> case alexGetChar input of
 882         Nothing -> errBrace input span
 883         Just ('\125',input) ->
 884           docCommentEnd input commentAcc docType buf span
 885         Just (_,_) -> go ('-':commentAcc) input docType False
 886       Just ('\123', input) -> case alexGetChar input of
 887         Nothing  -> errBrace input span
 888         Just ('-',input) -> do
 889           setInput input
 890           let cont = do input <- getInput; go commentAcc input docType False
 891           nested_comment cont span buf _len
 892         Just (_,_) -> go ('\123':commentAcc) input docType False
 893       Just (c,input) -> go (c:commentAcc) input docType False
 894
 895 withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (Located Token))
 896                  -> P (Located Token)
 897 withLexedDocType lexDocComment = do
 898   input@(AI _ buf) <- getInput
 899   case prevChar buf ' ' of
 900     '|' -> lexDocComment input ITdocCommentNext False
 901     '^' -> lexDocComment input ITdocCommentPrev False
 902     '$' -> lexDocComment input ITdocCommentNamed False
 903     '*' -> lexDocSection 1 input
 904     '#' -> lexDocComment input ITdocOptionsOld False
 905     _ -> panic "withLexedDocType: Bad doc type"
 906  where
 907     lexDocSection n input = case alexGetChar input of
 908       Just ('*', input) -> lexDocSection (n+1) input
 909       Just (_,   _)     -> lexDocComment input (ITdocSection n) True
 910       Nothing -> do setInput input; lexToken -- eof reached, lex it normally
 911
 912 -- RULES pragmas turn on the forall and '.' keywords, and we turn them
 913 -- off again at the end of the pragma.
 914 rulePrag :: Action
 915 rulePrag span _buf _len = do
 916   setExts (.|. bit inRulePragBit)
 917   return (L span ITrules_prag)
 918
 919 endPrag :: Action
 920 endPrag span _buf _len = do
 921   setExts (.&. complement (bit inRulePragBit))
 922   return (L span ITclose_prag)
 923
 924 -- docCommentEnd
 925 -------------------------------------------------------------------------------
 926 -- This function is quite tricky. We can't just return a new token, we also
 927 -- need to update the state of the parser. Why? Because the token is longer
 928 -- than what was lexed by Alex, and the lexToken function doesn't know this, so
 929 -- it writes the wrong token length to the parser state. This function is
 930 -- called afterwards, so it can just update the state.
 931
 932 docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
 933                  SrcSpan -> P (Located Token)
 934 docCommentEnd input commentAcc docType buf span = do
 935   setInput input
 936   let (AI loc nextBuf) = input
 937       comment = reverse commentAcc
 938       span' = mkSrcSpan (srcSpanStart span) loc
 939       last_len = byteDiff buf nextBuf
 940
 941   span `seq` setLastToken span' last_len
 942   return (L span' (docType comment))
 943
 944 errBrace :: AlexInput -> SrcSpan -> P a
 945 errBrace (AI end _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
 946
 947 open_brace, close_brace :: Action
 948 open_brace span _str _len = do
 949   ctx <- getContext
 950   setContext (NoLayout:ctx)
 951   return (L span ITocurly)
 952 close_brace span _str _len = do
 953   popContext
 954   return (L span ITccurly)
 955
 956 qvarid, qconid :: StringBuffer -> Int -> Token
 957 qvarid buf len = ITqvarid $! splitQualName buf len False
 958 qconid buf len = ITqconid $! splitQualName buf len False
 959
 960 splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString)
 961 -- takes a StringBuffer and a length, and returns the module name
 962 -- and identifier parts of a qualified name.  Splits at the *last* dot,
 963 -- because of hierarchical module names.
 964 splitQualName orig_buf len parens = split orig_buf orig_buf
 965   where
 966     split buf dot_buf
 967         | orig_buf `byteDiff` buf >= len  = done dot_buf
 968         | c == '.'                        = found_dot buf'
 969         | otherwise                       = split buf' dot_buf
 970       where
 971        (c,buf') = nextChar buf
 972
 973     -- careful, we might get names like M....
 974     -- so, if the character after the dot is not upper-case, this is
 975     -- the end of the qualifier part.
 976     found_dot buf -- buf points after the '.'
 977         | isUpper c    = split buf' buf
 978         | otherwise    = done buf
 979       where
 980        (c,buf') = nextChar buf
 981
 982     done dot_buf =
 983         (lexemeToFastString orig_buf (qual_size - 1),
 984          if parens -- Prelude.(+)
 985             then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2)
 986             else lexemeToFastString dot_buf (len - qual_size))
 987       where
 988         qual_size = orig_buf `byteDiff` dot_buf
 989
 990 varid :: Action
 991 varid span buf len =
 992   fs `seq`
 993   case lookupUFM reservedWordsFM fs of
 994         Just (keyword,0)    -> do
 995                 maybe_layout keyword
 996                 return (L span keyword)
 997         Just (keyword,exts) -> do
 998                 b <- extension (\i -> exts .&. i /= 0)
 999                 if b then do maybe_layout keyword
1000                              return (L span keyword)
1001                      else return (L span (ITvarid fs))
1002         _other -> return (L span (ITvarid fs))
1003   where
1004         fs = lexemeToFastString buf len
1005
1006 conid :: StringBuffer -> Int -> Token
1007 conid buf len = ITconid fs
1008   where fs = lexemeToFastString buf len
1009
1010 qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token
1011 qvarsym buf len = ITqvarsym $! splitQualName buf len False
1012 qconsym buf len = ITqconsym $! splitQualName buf len False
1013 prefixqvarsym buf len = ITprefixqvarsym $! splitQualName buf len True
1014 prefixqconsym buf len = ITprefixqconsym $! splitQualName buf len True
1015
1016 varsym, consym :: Action
1017 varsym = sym ITvarsym
1018 consym = sym ITconsym
1019
1020 sym :: (FastString -> Token) -> SrcSpan -> StringBuffer -> Int
1021     -> P (Located Token)
1022 sym con span buf len =
1023   case lookupUFM reservedSymsFM fs of
1024         Just (keyword,exts) -> do
1025                 b <- extension exts
1026                 if b then return (L span keyword)
1027                      else return (L span $! con fs)
1028         _other -> return (L span $! con fs)
1029   where
1030         fs = lexemeToFastString buf len
1031
1032 -- Variations on the integral numeric literal.
1033 tok_integral :: (Integer -> Token)
1034      -> (Integer -> Integer)
1035  --    -> (StringBuffer -> StringBuffer) -> (Int -> Int)
1036      -> Int -> Int
1037      -> (Integer, (Char->Int)) -> Action
1038 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len =
1039   return $ L span $ itint $! transint $ parseUnsignedInteger
1040      (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
1041
1042 -- some conveniences for use with tok_integral
1043 tok_num :: (Integer -> Integer)
1044         -> Int -> Int
1045         -> (Integer, (Char->Int)) -> Action
1046 tok_num = tok_integral ITinteger
1047 tok_primint :: (Integer -> Integer)
1048             -> Int -> Int
1049             -> (Integer, (Char->Int)) -> Action
1050 tok_primint = tok_integral ITprimint
1051 tok_primword :: Int -> Int
1052              -> (Integer, (Char->Int)) -> Action
1053 tok_primword = tok_integral ITprimword positive
1054 positive, negative :: (Integer -> Integer)
1055 positive = id
1056 negative = negate
1057 decimal, octal, hexadecimal :: (Integer, Char -> Int)
1058 decimal = (10,octDecDigit)
1059 octal = (8,octDecDigit)
1060 hexadecimal = (16,hexDigit)
1061
1062 -- readRational can understand negative rationals, exponents, everything.
1063 tok_float, tok_primfloat, tok_primdouble :: String -> Token
1064 tok_float        str = ITrational   $! readRational str
1065 tok_primfloat    str = ITprimfloat  $! readRational str
1066 tok_primdouble   str = ITprimdouble $! readRational str
1067
1068 -- -----------------------------------------------------------------------------
1069 -- Layout processing
1070
1071 -- we're at the first token on a line, insert layout tokens if necessary
1072 do_bol :: Action
1073 do_bol span _str _len = do
1074         pos <- getOffside
1075         case pos of
1076             LT -> do
1077                 --trace "layout: inserting '}'" $ do
1078                 popContext
1079                 -- do NOT pop the lex state, we might have a ';' to insert
1080                 return (L span ITvccurly)
1081             EQ -> do
1082                 --trace "layout: inserting ';'" $ do
1083                 _ <- popLexState
1084                 return (L span ITsemi)
1085             GT -> do
1086                 _ <- popLexState
1087                 lexToken
1088
1089 -- certain keywords put us in the "layout" state, where we might
1090 -- add an opening curly brace.
1091 maybe_layout :: Token -> P ()
1092 maybe_layout t = do -- If the alternative layout rule is enabled then
1093                     -- we never create an implicit layout context here.
1094                     -- Layout is handled XXX instead.
1095                     -- The code for closing implicit contexts, or
1096                     -- inserting implicit semi-colons, is therefore
1097                     -- irrelevant as it only applies in an implicit
1098                     -- context.
1099                     alr <- extension alternativeLayoutRule
1100                     unless alr $ f t
1101     where f ITdo    = pushLexState layout_do
1102           f ITmdo   = pushLexState layout_do
1103           f ITof    = pushLexState layout
1104           f ITlet   = pushLexState layout
1105           f ITwhere = pushLexState layout
1106           f ITrec   = pushLexState layout
1107           f _       = return ()
1108
1109 -- Pushing a new implicit layout context.  If the indentation of the
1110 -- next token is not greater than the previous layout context, then
1111 -- Haskell 98 says that the new layout context should be empty; that is
1112 -- the lexer must generate {}.
1113 --
1114 -- We are slightly more lenient than this: when the new context is started
1115 -- by a 'do', then we allow the new context to be at the same indentation as
1116 -- the previous context.  This is what the 'strict' argument is for.
1117 --
1118 new_layout_context :: Bool -> Action
1119 new_layout_context strict span _buf _len = do
1120     _ <- popLexState
1121     (AI l _) <- getInput
1122     let offset = srcLocCol l
1123     ctx <- getContext
1124     nondecreasing <- extension nondecreasingIndentation
1125     let strict' = strict || not nondecreasing
1126     case ctx of
1127         Layout prev_off : _  |
1128            (strict'     && prev_off >= offset  ||
1129             not strict' && prev_off > offset) -> do
1130                 -- token is indented to the left of the previous context.
1131                 -- we must generate a {} sequence now.
1132                 pushLexState layout_left
1133                 return (L span ITvocurly)
1134         _ -> do
1135                 setContext (Layout offset : ctx)
1136                 return (L span ITvocurly)
1137
1138 do_layout_left :: Action
1139 do_layout_left span _buf _len = do
1140     _ <- popLexState
1141     pushLexState bol  -- we must be at the start of a line
1142     return (L span ITvccurly)
1143
1144 -- -----------------------------------------------------------------------------
1145 -- LINE pragmas
1146
1147 setLine :: Int -> Action
1148 setLine code span buf len = do
1149   let line = parseUnsignedInteger buf len 10 octDecDigit
1150   setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
1151         -- subtract one: the line number refers to the *following* line
1152   _ <- popLexState
1153   pushLexState code
1154   lexToken
1155
1156 setFile :: Int -> Action
1157 setFile code span buf len = do
1158   let file = lexemeToFastString (stepOn buf) (len-2)
1159   setAlrLastLoc noSrcSpan
1160   setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
1161   _ <- popLexState
1162   pushLexState code
1163   lexToken
1164
1165
1166 -- -----------------------------------------------------------------------------
1167 -- Options, includes and language pragmas.
1168
1169 lex_string_prag :: (String -> Token) -> Action
1170 lex_string_prag mkTok span _buf _len
1171     = do input <- getInput
1172          start <- getSrcLoc
1173          tok <- go [] input
1174          end <- getSrcLoc
1175          return (L (mkSrcSpan start end) tok)
1176     where go acc input
1177               = if isString input "#-}"
1178                    then do setInput input
1179                            return (mkTok (reverse acc))
1180                    else case alexGetChar input of
1181                           Just (c,i) -> go (c:acc) i
1182                           Nothing -> err input
1183           isString _ [] = True
1184           isString i (x:xs)
1185               = case alexGetChar i of
1186                   Just (c,i') | c == x    -> isString i' xs
1187                   _other -> False
1188           err (AI end _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
1189
1190
1191 -- -----------------------------------------------------------------------------
1192 -- Strings & Chars
1193
1194 -- This stuff is horrible.  I hates it.
1195
1196 lex_string_tok :: Action
1197 lex_string_tok span _buf _len = do
1198   tok <- lex_string ""
1199   end <- getSrcLoc
1200   return (L (mkSrcSpan (srcSpanStart span) end) tok)
1201
1202 lex_string :: String -> P Token
1203 lex_string s = do
1204   i <- getInput
1205   case alexGetChar' i of
1206     Nothing -> lit_error i
1207
1208     Just ('"',i)  -> do
1209         setInput i
1210         magicHash <- extension magicHashEnabled
1211         if magicHash
1212           then do
1213             i <- getInput
1214             case alexGetChar' i of
1215               Just ('#',i) -> do
1216                    setInput i
1217                    if any (> '\xFF') s
1218                     then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
1219                     else let s' = mkZFastString (reverse s) in
1220                          return (ITprimstring s')
1221                         -- mkZFastString is a hack to avoid encoding the
1222                         -- string in UTF-8.  We just want the exact bytes.
1223               _other ->
1224                 return (ITstring (mkFastString (reverse s)))
1225           else
1226                 return (ITstring (mkFastString (reverse s)))
1227
1228     Just ('\\',i)
1229         | Just ('&',i) <- next -> do
1230                 setInput i; lex_string s
1231         | Just (c,i) <- next, c <= '\x7f' && is_space c -> do
1232                            -- is_space only works for <= '\x7f' (#3751)
1233                 setInput i; lex_stringgap s
1234         where next = alexGetChar' i
1235
1236     Just (c, i1) -> do
1237         case c of
1238           '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s)
1239           c | isAny c -> do setInput i1; lex_string (c:s)
1240           _other -> lit_error i
1241
1242 lex_stringgap :: String -> P Token
1243 lex_stringgap s = do
1244   i <- getInput
1245   c <- getCharOrFail i
1246   case c of
1247     '\\' -> lex_string s
1248     c | is_space c -> lex_stringgap s
1249     _other -> lit_error i
1250
1251
1252 lex_char_tok :: Action
1253 -- Here we are basically parsing character literals, such as 'x' or '\n'
1254 -- but, when Template Haskell is on, we additionally spot
1255 -- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
1256 -- but WITHOUT CONSUMING the x or T part  (the parser does that).
1257 -- So we have to do two characters of lookahead: when we see 'x we need to
1258 -- see if there's a trailing quote
1259 lex_char_tok span _buf _len = do        -- We've seen '
1260    i1 <- getInput       -- Look ahead to first character
1261    let loc = srcSpanStart span
1262    case alexGetChar' i1 of
1263         Nothing -> lit_error  i1
1264
1265         Just ('\'', i2@(AI end2 _)) -> do       -- We've seen ''
1266                   th_exts <- extension thEnabled
1267                   if th_exts then do
1268                         setInput i2
1269                         return (L (mkSrcSpan loc end2)  ITtyQuote)
1270                    else lit_error i1
1271
1272         Just ('\\', i2@(AI _end2 _)) -> do      -- We've seen 'backslash
1273                   setInput i2
1274                   lit_ch <- lex_escape
1275                   i3 <- getInput
1276                   mc <- getCharOrFail i3 -- Trailing quote
1277                   if mc == '\'' then finish_char_tok loc lit_ch
1278                                 else lit_error i3
1279
1280         Just (c, i2@(AI _end2 _))
1281                 | not (isAny c) -> lit_error i1
1282                 | otherwise ->
1283
1284                 -- We've seen 'x, where x is a valid character
1285                 --  (i.e. not newline etc) but not a quote or backslash
1286            case alexGetChar' i2 of      -- Look ahead one more character
1287                 Just ('\'', i3) -> do   -- We've seen 'x'
1288                         setInput i3
1289                         finish_char_tok loc c
1290                 _other -> do            -- We've seen 'x not followed by quote
1291                                         -- (including the possibility of EOF)
1292                                         -- If TH is on, just parse the quote only
1293                         th_exts <- extension thEnabled
1294                         let (AI end _) = i1
1295                         if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
1296                                    else lit_error i2
1297
1298 finish_char_tok :: SrcLoc -> Char -> P (Located Token)
1299 finish_char_tok loc ch  -- We've already seen the closing quote
1300                         -- Just need to check for trailing #
1301   = do  magicHash <- extension magicHashEnabled
1302         i@(AI end _) <- getInput
1303         if magicHash then do
1304                 case alexGetChar' i of
1305                         Just ('#',i@(AI end _)) -> do
1306                                 setInput i
1307                                 return (L (mkSrcSpan loc end) (ITprimchar ch))
1308                         _other ->
1309                                 return (L (mkSrcSpan loc end) (ITchar ch))
1310             else do
1311                    return (L (mkSrcSpan loc end) (ITchar ch))
1312
1313 isAny :: Char -> Bool
1314 isAny c | c > '\x7f' = isPrint c
1315         | otherwise  = is_any c
1316
1317 lex_escape :: P Char
1318 lex_escape = do
1319   i0 <- getInput
1320   c <- getCharOrFail i0
1321   case c of
1322         'a'   -> return '\a'
1323         'b'   -> return '\b'
1324         'f'   -> return '\f'
1325         'n'   -> return '\n'
1326         'r'   -> return '\r'
1327         't'   -> return '\t'
1328         'v'   -> return '\v'
1329         '\\'  -> return '\\'
1330         '"'   -> return '\"'
1331         '\''  -> return '\''
1332         '^'   -> do i1 <- getInput
1333                     c <- getCharOrFail i1
1334                     if c >= '@' && c <= '_'
1335                         then return (chr (ord c - ord '@'))
1336                         else lit_error i1
1337
1338         'x'   -> readNum is_hexdigit 16 hexDigit
1339         'o'   -> readNum is_octdigit  8 octDecDigit
1340         x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)
1341
1342         c1 ->  do
1343            i <- getInput
1344            case alexGetChar' i of
1345             Nothing -> lit_error i0
1346             Just (c2,i2) ->
1347               case alexGetChar' i2 of
1348                 Nothing -> do lit_error i0
1349                 Just (c3,i3) ->
1350                    let str = [c1,c2,c3] in
1351                    case [ (c,rest) | (p,c) <- silly_escape_chars,
1352                                      Just rest <- [stripPrefix p str] ] of
1353                           (escape_char,[]):_ -> do
1354                                 setInput i3
1355                                 return escape_char
1356                           (escape_char,_:_):_ -> do
1357                                 setInput i2
1358                                 return escape_char
1359                           [] -> lit_error i0
1360
1361 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char
1362 readNum is_digit base conv = do
1363   i <- getInput
1364   c <- getCharOrFail i
1365   if is_digit c
1366         then readNum2 is_digit base conv (conv c)
1367         else lit_error i
1368
1369 readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char
1370 readNum2 is_digit base conv i = do
1371   input <- getInput
1372   read i input
1373   where read i input = do
1374           case alexGetChar' input of
1375             Just (c,input') | is_digit c -> do
1376                let i' = i*base + conv c
1377                if i' > 0x10ffff
1378                   then setInput input >> lexError "numeric escape sequence out of range"
1379                   else read i' input'
1380             _other -> do
1381               setInput input; return (chr i)
1382
1383
1384 silly_escape_chars :: [(String, Char)]
1385 silly_escape_chars = [
1386         ("NUL", '\NUL'),
1387         ("SOH", '\SOH'),
1388         ("STX", '\STX'),
1389         ("ETX", '\ETX'),
1390         ("EOT", '\EOT'),
1391         ("ENQ", '\ENQ'),
1392         ("ACK", '\ACK'),
1393         ("BEL", '\BEL'),
1394         ("BS", '\BS'),
1395         ("HT", '\HT'),
1396         ("LF", '\LF'),
1397         ("VT", '\VT'),
1398         ("FF", '\FF'),
1399         ("CR", '\CR'),
1400         ("SO", '\SO'),
1401         ("SI", '\SI'),
1402         ("DLE", '\DLE'),
1403         ("DC1", '\DC1'),
1404         ("DC2", '\DC2'),
1405         ("DC3", '\DC3'),
1406         ("DC4", '\DC4'),
1407         ("NAK", '\NAK'),
1408         ("SYN", '\SYN'),
1409         ("ETB", '\ETB'),
1410         ("CAN", '\CAN'),
1411         ("EM", '\EM'),
1412         ("SUB", '\SUB'),
1413         ("ESC", '\ESC'),
1414         ("FS", '\FS'),
1415         ("GS", '\GS'),
1416         ("RS", '\RS'),
1417         ("US", '\US'),
1418         ("SP", '\SP'),
1419         ("DEL", '\DEL')
1420         ]
1421
1422 -- before calling lit_error, ensure that the current input is pointing to
1423 -- the position of the error in the buffer.  This is so that we can report
1424 -- a correct location to the user, but also so we can detect UTF-8 decoding
1425 -- errors if they occur.
1426 lit_error :: AlexInput -> P a
1427 lit_error i = do setInput i; lexError "lexical error in string/character literal"
1428
1429 getCharOrFail :: AlexInput -> P Char
1430 getCharOrFail i =  do
1431   case alexGetChar' i of
1432         Nothing -> lexError "unexpected end-of-file in string/character literal"
1433         Just (c,i)  -> do setInput i; return c
1434
1435 -- -----------------------------------------------------------------------------
1436 -- QuasiQuote
1437
1438 lex_quasiquote_tok :: Action
1439 lex_quasiquote_tok span buf len = do
1440   let quoter = tail (lexemeToString buf (len - 1))
1441                 -- 'tail' drops the initial '[',
1442                 -- while the -1 drops the trailing '|'
1443   quoteStart <- getSrcLoc
1444   quote <- lex_quasiquote ""
1445   end <- getSrcLoc
1446   return (L (mkSrcSpan (srcSpanStart span) end)
1447            (ITquasiQuote (mkFastString quoter,
1448                           mkFastString (reverse quote),
1449                           mkSrcSpan quoteStart end)))
1450
1451 lex_quasiquote :: String -> P String
1452 lex_quasiquote s = do
1453   i <- getInput
1454   case alexGetChar' i of
1455     Nothing -> lit_error i
1456
1457     Just ('\\',i)
1458         | Just ('|',i) <- next -> do
1459                 setInput i; lex_quasiquote ('|' : s)
1460         | Just (']',i) <- next -> do
1461                 setInput i; lex_quasiquote (']' : s)
1462         where next = alexGetChar' i
1463
1464     Just ('|',i)
1465         | Just (']',i) <- next -> do
1466                 setInput i; return s
1467         where next = alexGetChar' i
1468
1469     Just (c, i) -> do
1470          setInput i; lex_quasiquote (c : s)
1471
1472 -- -----------------------------------------------------------------------------
1473 -- Warnings
1474
1475 warn :: DynFlag -> SDoc -> Action
1476 warn option warning srcspan _buf _len = do
1477     addWarning option srcspan warning
1478     lexToken
1479
1480 warnThen :: DynFlag -> SDoc -> Action -> Action
1481 warnThen option warning action srcspan buf len = do
1482     addWarning option srcspan warning
1483     action srcspan buf len
1484
1485 -- -----------------------------------------------------------------------------
1486 -- The Parse Monad
1487
1488 data LayoutContext
1489   = NoLayout
1490   | Layout !Int
1491   deriving Show
1492
1493 data ParseResult a
1494   = POk PState a
1495   | PFailed
1496         SrcSpan         -- The start and end of the text span related to
1497                         -- the error.  Might be used in environments which can
1498                         -- show this span, e.g. by highlighting it.
1499         Message         -- The error message
1500
1501 data PState = PState {
1502         buffer     :: StringBuffer,
1503         dflags     :: DynFlags,
1504         messages   :: Messages,
1505         last_loc   :: SrcSpan,  -- pos of previous token
1506         last_len   :: !Int,     -- len of previous token
1507         loc        :: SrcLoc,   -- current loc (end of prev token + 1)
1508         extsBitmap :: !Int,     -- bitmap that determines permitted extensions
1509         context    :: [LayoutContext],
1510         lex_state  :: [Int],
1511         -- Used in the alternative layout rule:
1512         -- These tokens are the next ones to be sent out. They are
1513         -- just blindly emitted, without the rule looking at them again:
1514         alr_pending_implicit_tokens :: [Located Token],
1515         -- This is the next token to be considered or, if it is Nothing,
1516         -- we need to get the next token from the input stream:
1517         alr_next_token :: Maybe (Located Token),
1518         -- This is what we consider to be the locatino of the last token
1519         -- emitted:
1520         alr_last_loc :: SrcSpan,
1521         -- The stack of layout contexts:
1522         alr_context :: [ALRContext],
1523         -- Are we expecting a '{'? If it's Just, then the ALRLayout tells
1524         -- us what sort of layout the '{' will open:
1525         alr_expecting_ocurly :: Maybe ALRLayout,
1526         -- Have we just had the '}' for a let block? If so, than an 'in'
1527         -- token doesn't need to close anything:
1528         alr_justClosedExplicitLetBlock :: Bool
1529      }
1530         -- last_loc and last_len are used when generating error messages,
1531         -- and in pushCurrentContext only.  Sigh, if only Happy passed the
1532         -- current token to happyError, we could at least get rid of last_len.
1533         -- Getting rid of last_loc would require finding another way to
1534         -- implement pushCurrentContext (which is only called from one place).
1535
1536 data ALRContext = ALRNoLayout Bool{- does it contain commas? -}
1537                               Bool{- is it a 'let' block? -}
1538                 | ALRLayout ALRLayout Int
1539 data ALRLayout = ALRLayoutLet
1540                | ALRLayoutWhere
1541                | ALRLayoutOf
1542                | ALRLayoutDo
1543
1544 newtype P a = P { unP :: PState -> ParseResult a }
1545
1546 instance Monad P where
1547   return = returnP
1548   (>>=) = thenP
1549   fail = failP
1550
1551 returnP :: a -> P a
1552 returnP a = a `seq` (P $ \s -> POk s a)
1553
1554 thenP :: P a -> (a -> P b) -> P b
1555 (P m) `thenP` k = P $ \ s ->
1556         case m s of
1557                 POk s1 a         -> (unP (k a)) s1
1558                 PFailed span err -> PFailed span err
1559
1560 failP :: String -> P a
1561 failP msg = P $ \s -> PFailed (last_loc s) (text msg)
1562
1563 failMsgP :: String -> P a
1564 failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
1565
1566 failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
1567 failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
1568
1569 failSpanMsgP :: SrcSpan -> SDoc -> P a
1570 failSpanMsgP span msg = P $ \_ -> PFailed span msg
1571
1572 getPState :: P PState
1573 getPState = P $ \s -> POk s s
1574
1575 getDynFlags :: P DynFlags
1576 getDynFlags = P $ \s -> POk s (dflags s)
1577
1578 withThisPackage :: (PackageId -> a) -> P a
1579 withThisPackage f
1580  = do   pkg     <- liftM thisPackage getDynFlags
1581         return  $ f pkg
1582
1583 extension :: (Int -> Bool) -> P Bool
1584 extension p = P $ \s -> POk s (p $! extsBitmap s)
1585
1586 getExts :: P Int
1587 getExts = P $ \s -> POk s (extsBitmap s)
1588
1589 setExts :: (Int -> Int) -> P ()
1590 setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } ()
1591
1592 setSrcLoc :: SrcLoc -> P ()
1593 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
1594
1595 getSrcLoc :: P SrcLoc
1596 getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
1597
1598 setLastToken :: SrcSpan -> Int -> P ()
1599 setLastToken loc len = P $ \s -> POk s {
1600   last_loc=loc,
1601   last_len=len
1602   } ()
1603
1604 data AlexInput = AI SrcLoc StringBuffer
1605
1606 alexInputPrevChar :: AlexInput -> Char
1607 alexInputPrevChar (AI _ buf) = prevChar buf '\n'
1608
1609 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
1610 alexGetChar (AI loc s)
1611   | atEnd s   = Nothing
1612   | otherwise = adj_c `seq` loc' `seq` s' `seq`
1613                 --trace (show (ord c)) $
1614                 Just (adj_c, (AI loc' s'))
1615   where (c,s') = nextChar s
1616         loc'   = advanceSrcLoc loc c
1617
1618         non_graphic     = '\x0'
1619         upper           = '\x1'
1620         lower           = '\x2'
1621         digit           = '\x3'
1622         symbol          = '\x4'
1623         space           = '\x5'
1624         other_graphic   = '\x6'
1625
1626         adj_c
1627           | c <= '\x06' = non_graphic
1628           | c <= '\x7f' = c
1629           -- Alex doesn't handle Unicode, so when Unicode
1630           -- character is encountered we output these values
1631           -- with the actual character value hidden in the state.
1632           | otherwise =
1633                 case generalCategory c of
1634                   UppercaseLetter       -> upper
1635                   LowercaseLetter       -> lower
1636                   TitlecaseLetter       -> upper
1637                   ModifierLetter        -> other_graphic
1638                   OtherLetter           -> lower -- see #1103
1639                   NonSpacingMark        -> other_graphic
1640                   SpacingCombiningMark  -> other_graphic
1641                   EnclosingMark         -> other_graphic
1642                   DecimalNumber         -> digit
1643                   LetterNumber          -> other_graphic
1644                   OtherNumber           -> digit -- see #4373
1645                   ConnectorPunctuation  -> symbol
1646                   DashPunctuation       -> symbol
1647                   OpenPunctuation       -> other_graphic
1648                   ClosePunctuation      -> other_graphic
1649                   InitialQuote          -> other_graphic
1650                   FinalQuote            -> other_graphic
1651                   OtherPunctuation      -> symbol
1652                   MathSymbol            -> symbol
1653                   CurrencySymbol        -> symbol
1654                   ModifierSymbol        -> symbol
1655                   OtherSymbol           -> symbol
1656                   Space                 -> space
1657                   _other                -> non_graphic
1658
1659 -- This version does not squash unicode characters, it is used when
1660 -- lexing strings.
1661 alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
1662 alexGetChar' (AI loc s)
1663   | atEnd s   = Nothing
1664   | otherwise = c `seq` loc' `seq` s' `seq`
1665                 --trace (show (ord c)) $
1666                 Just (c, (AI loc' s'))
1667   where (c,s') = nextChar s
1668         loc'   = advanceSrcLoc loc c
1669
1670 getInput :: P AlexInput
1671 getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)
1672
1673 setInput :: AlexInput -> P ()
1674 setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()
1675
1676 nextIsEOF :: P Bool
1677 nextIsEOF = do
1678   AI _ s <- getInput
1679   return $ atEnd s
1680
1681 pushLexState :: Int -> P ()
1682 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
1683
1684 popLexState :: P Int
1685 popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
1686
1687 getLexState :: P Int
1688 getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
1689
1690 popNextToken :: P (Maybe (Located Token))
1691 popNextToken
1692     = P $ \s@PState{ alr_next_token = m } ->
1693               POk (s {alr_next_token = Nothing}) m
1694
1695 activeContext :: P Bool
1696 activeContext = do
1697   ctxt <- getALRContext
1698   expc <- getAlrExpectingOCurly
1699   impt <- implicitTokenPending
1700   case (ctxt,expc) of
1701     ([],Nothing) -> return impt
1702     _other       -> return True
1703
1704 setAlrLastLoc :: SrcSpan -> P ()
1705 setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
1706
1707 getAlrLastLoc :: P SrcSpan
1708 getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
1709
1710 getALRContext :: P [ALRContext]
1711 getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs
1712
1713 setALRContext :: [ALRContext] -> P ()
1714 setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()
1715
1716 getJustClosedExplicitLetBlock :: P Bool
1717 getJustClosedExplicitLetBlock
1718  = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b
1719
1720 setJustClosedExplicitLetBlock :: Bool -> P ()
1721 setJustClosedExplicitLetBlock b
1722  = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
1723
1724 setNextToken :: Located Token -> P ()
1725 setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
1726
1727 implicitTokenPending :: P Bool
1728 implicitTokenPending
1729     = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
1730               case ts of
1731               [] -> POk s False
1732               _  -> POk s True
1733
1734 popPendingImplicitToken :: P (Maybe (Located Token))
1735 popPendingImplicitToken
1736     = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
1737               case ts of
1738               [] -> POk s Nothing
1739               (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
1740
1741 setPendingImplicitTokens :: [Located Token] -> P ()
1742 setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
1743
1744 getAlrExpectingOCurly :: P (Maybe ALRLayout)
1745 getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b
1746
1747 setAlrExpectingOCurly :: Maybe ALRLayout -> P ()
1748 setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
1749
1750 -- for reasons of efficiency, flags indicating language extensions (eg,
1751 -- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed
1752 -- integer
1753
1754 genericsBit :: Int
1755 genericsBit = 0 -- {| and |}
1756 ffiBit :: Int
1757 ffiBit     = 1
1758 parrBit :: Int
1759 parrBit    = 2
1760 arrowsBit :: Int
1761 arrowsBit  = 4
1762 thBit :: Int
1763 thBit      = 5
1764 ipBit :: Int
1765 ipBit      = 6
1766 explicitForallBit :: Int
1767 explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
1768 bangPatBit :: Int
1769 bangPatBit = 8  -- Tells the parser to understand bang-patterns
1770                 -- (doesn't affect the lexer)
1771 tyFamBit :: Int
1772 tyFamBit   = 9  -- indexed type families: 'family' keyword and kind sigs
1773 haddockBit :: Int
1774 haddockBit = 10 -- Lex and parse Haddock comments
1775 magicHashBit :: Int
1776 magicHashBit = 11 -- "#" in both functions and operators
1777 kindSigsBit :: Int
1778 kindSigsBit = 12 -- Kind signatures on type variables
1779 recursiveDoBit :: Int
1780 recursiveDoBit = 13 -- mdo
1781 unicodeSyntaxBit :: Int
1782 unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
1783 unboxedTuplesBit :: Int
1784 unboxedTuplesBit = 15 -- (# and #)
1785 datatypeContextsBit :: Int
1786 datatypeContextsBit = 16
1787 transformComprehensionsBit :: Int
1788 transformComprehensionsBit = 17
1789 qqBit :: Int
1790 qqBit      = 18 -- enable quasiquoting
1791 inRulePragBit :: Int
1792 inRulePragBit = 19
1793 rawTokenStreamBit :: Int
1794 rawTokenStreamBit = 20 -- producing a token stream with all comments included
1795 recBit :: Int
1796 recBit = 22 -- rec
1797 alternativeLayoutRuleBit :: Int
1798 alternativeLayoutRuleBit = 23
1799 relaxedLayoutBit :: Int
1800 relaxedLayoutBit = 24
1801 nondecreasingIndentationBit :: Int
1802 nondecreasingIndentationBit = 25
1803
1804 always :: Int -> Bool
1805 always           _     = True
1806 genericsEnabled :: Int -> Bool
1807 genericsEnabled  flags = testBit flags genericsBit
1808 parrEnabled :: Int -> Bool
1809 parrEnabled      flags = testBit flags parrBit
1810 arrowsEnabled :: Int -> Bool
1811 arrowsEnabled    flags = testBit flags arrowsBit
1812 thEnabled :: Int -> Bool
1813 thEnabled        flags = testBit flags thBit
1814 ipEnabled :: Int -> Bool
1815 ipEnabled        flags = testBit flags ipBit
1816 explicitForallEnabled :: Int -> Bool
1817 explicitForallEnabled flags = testBit flags explicitForallBit
1818 bangPatEnabled :: Int -> Bool
1819 bangPatEnabled   flags = testBit flags bangPatBit
1820 -- tyFamEnabled :: Int -> Bool
1821 -- tyFamEnabled     flags = testBit flags tyFamBit
1822 haddockEnabled :: Int -> Bool
1823 haddockEnabled   flags = testBit flags haddockBit
1824 magicHashEnabled :: Int -> Bool
1825 magicHashEnabled flags = testBit flags magicHashBit
1826 -- kindSigsEnabled :: Int -> Bool
1827 -- kindSigsEnabled  flags = testBit flags kindSigsBit
1828 unicodeSyntaxEnabled :: Int -> Bool
1829 unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
1830 unboxedTuplesEnabled :: Int -> Bool
1831 unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
1832 datatypeContextsEnabled :: Int -> Bool
1833 datatypeContextsEnabled flags = testBit flags datatypeContextsBit
1834 qqEnabled :: Int -> Bool
1835 qqEnabled        flags = testBit flags qqBit
1836 -- inRulePrag :: Int -> Bool
1837 -- inRulePrag       flags = testBit flags inRulePragBit
1838 rawTokenStreamEnabled :: Int -> Bool
1839 rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit
1840 alternativeLayoutRule :: Int -> Bool
1841 alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit
1842 relaxedLayout :: Int -> Bool
1843 relaxedLayout flags = testBit flags relaxedLayoutBit
1844 nondecreasingIndentation :: Int -> Bool
1845 nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit
1846
1847 -- PState for parsing options pragmas
1848 --
1849 pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
1850 pragState dynflags buf loc = (mkPState dynflags buf loc) {
1851                                  lex_state = [bol, option_prags, 0]
1852                              }
1853
1854 -- create a parse state
1855 --
1856 mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
1857 mkPState flags buf loc =
1858   PState {
1859       buffer          = buf,
1860       dflags        = flags,
1861       messages      = emptyMessages,
1862       last_loc      = mkSrcSpan loc loc,
1863       last_len      = 0,
1864       loc           = loc,
1865       extsBitmap    = fromIntegral bitmap,
1866       context       = [],
1867       lex_state     = [bol, 0],
1868       alr_pending_implicit_tokens = [],
1869       alr_next_token = Nothing,
1870       alr_last_loc = noSrcSpan,
1871       alr_context = [],
1872       alr_expecting_ocurly = Nothing,
1873       alr_justClosedExplicitLetBlock = False
1874     }
1875     where
1876       bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
1877                .|. ffiBit            `setBitIf` xopt Opt_ForeignFunctionInterface flags
1878                .|. parrBit           `setBitIf` xopt Opt_ParallelArrays  flags
1879                .|. arrowsBit         `setBitIf` xopt Opt_Arrows          flags
1880                .|. thBit             `setBitIf` xopt Opt_TemplateHaskell flags
1881                .|. qqBit             `setBitIf` xopt Opt_QuasiQuotes     flags
1882                .|. ipBit             `setBitIf` xopt Opt_ImplicitParams  flags
1883                .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll  flags
1884                .|. bangPatBit        `setBitIf` xopt Opt_BangPatterns flags
1885                .|. tyFamBit          `setBitIf` xopt Opt_TypeFamilies flags
1886                .|. haddockBit        `setBitIf` dopt Opt_Haddock      flags
1887                .|. magicHashBit      `setBitIf` xopt Opt_MagicHash    flags
1888                .|. kindSigsBit       `setBitIf` xopt Opt_KindSignatures flags
1889                .|. recursiveDoBit    `setBitIf` xopt Opt_RecursiveDo flags
1890                .|. recBit            `setBitIf` xopt Opt_DoRec  flags
1891                .|. recBit            `setBitIf` xopt Opt_Arrows flags
1892                .|. unicodeSyntaxBit  `setBitIf` xopt Opt_UnicodeSyntax flags
1893                .|. unboxedTuplesBit  `setBitIf` xopt Opt_UnboxedTuples flags
1894                .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
1895                .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
1896                .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
1897                .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
1898                .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
1899                .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
1900       --
1901       setBitIf :: Int -> Bool -> Int
1902       b `setBitIf` cond | cond      = bit b
1903                         | otherwise = 0
1904
1905 addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
1906 addWarning option srcspan warning
1907  = P $ \s@PState{messages=(ws,es), dflags=d} ->
1908        let warning' = mkWarnMsg srcspan alwaysQualify warning
1909            ws' = if dopt option d then ws `snocBag` warning' else ws
1910        in POk s{messages=(ws', es)} ()
1911
1912 getMessages :: PState -> Messages
1913 getMessages PState{messages=ms} = ms
1914
1915 getContext :: P [LayoutContext]
1916 getContext = P $ \s@PState{context=ctx} -> POk s ctx
1917
1918 setContext :: [LayoutContext] -> P ()
1919 setContext ctx = P $ \s -> POk s{context=ctx} ()
1920
1921 popContext :: P ()
1922 popContext = P $ \ s@(PState{ buffer = buf, context = ctx,
1923                               last_len = len, last_loc = last_loc }) ->
1924   case ctx of
1925         (_:tl) -> POk s{ context = tl } ()
1926         []     -> PFailed last_loc (srcParseErr buf len)
1927
1928 -- Push a new layout context at the indentation of the last token read.
1929 -- This is only used at the outer level of a module when the 'module'
1930 -- keyword is missing.
1931 pushCurrentContext :: P ()
1932 pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } ->
1933     POk s{context = Layout (srcSpanStartCol loc) : ctx} ()
1934
1935 getOffside :: P Ordering
1936 getOffside = P $ \s@PState{last_loc=loc, context=stk} ->
1937                 let offs = srcSpanStartCol loc in
1938                 let ord = case stk of
1939                         (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $
1940                                         compare offs n
1941                         _            -> GT
1942                 in POk s ord
1943
1944 -- ---------------------------------------------------------------------------
1945 -- Construct a parse error
1946
1947 srcParseErr
1948   :: StringBuffer       -- current buffer (placed just after the last token)
1949   -> Int                -- length of the previous token
1950   -> Message
1951 srcParseErr buf len
1952   = hcat [ if null token
1953              then ptext (sLit "parse error (possibly incorrect indentation)")
1954              else hcat [ptext (sLit "parse error on input "),
1955                         char '`', text token, char '\'']
1956     ]
1957   where token = lexemeToString (offsetBytes (-len) buf) len
1958
1959 -- Report a parse failure, giving the span of the previous token as
1960 -- the location of the error.  This is the entry point for errors
1961 -- detected during parsing.
1962 srcParseFail :: P a
1963 srcParseFail = P $ \PState{ buffer = buf, last_len = len,
1964                             last_loc = last_loc } ->
1965     PFailed last_loc (srcParseErr buf len)
1966
1967 -- A lexical error is reported at a particular position in the source file,
1968 -- not over a token range.
1969 lexError :: String -> P a
1970 lexError str = do
1971   loc <- getSrcLoc
1972   (AI end buf) <- getInput
1973   reportLexError loc end buf str
1974
1975 -- -----------------------------------------------------------------------------
1976 -- This is the top-level function: called from the parser each time a
1977 -- new token is to be read from the input.
1978
1979 lexer :: (Located Token -> P a) -> P a
1980 lexer cont = do
1981   alr <- extension alternativeLayoutRule
1982   let lexTokenFun = if alr then lexTokenAlr else lexToken
1983   tok@(L _span _tok__) <- lexTokenFun
1984   --trace ("token: " ++ show _tok__) $ do
1985   cont tok
1986
1987 lexTokenAlr :: P (Located Token)
1988 lexTokenAlr = do mPending <- popPendingImplicitToken
1989                  t <- case mPending of
1990                       Nothing ->
1991                           do mNext <- popNextToken
1992                              t <- case mNext of
1993                                   Nothing -> lexToken
1994                                   Just next -> return next
1995                              alternativeLayoutRuleToken t
1996                       Just t ->
1997                           return t
1998                  setAlrLastLoc (getLoc t)
1999                  case unLoc t of
2000                      ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
2001                      ITlet   -> setAlrExpectingOCurly (Just ALRLayoutLet)
2002                      ITof    -> setAlrExpectingOCurly (Just ALRLayoutOf)
2003                      ITdo    -> setAlrExpectingOCurly (Just ALRLayoutDo)
2004                      ITmdo   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2005                      ITrec   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2006                      _       -> return ()
2007                  return t
2008
2009 alternativeLayoutRuleToken :: Located Token -> P (Located Token)
2010 alternativeLayoutRuleToken t
2011     = do context <- getALRContext
2012          lastLoc <- getAlrLastLoc
2013          mExpectingOCurly <- getAlrExpectingOCurly
2014          justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
2015          setJustClosedExplicitLetBlock False
2016          dflags <- getDynFlags
2017          let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags
2018              thisLoc = getLoc t
2019              thisCol = srcSpanStartCol thisLoc
2020              newLine = (lastLoc == noSrcSpan)
2021                     || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc)
2022          case (unLoc t, context, mExpectingOCurly) of
2023              -- This case handles a GHC extension to the original H98
2024              -- layout rule...
2025              (ITocurly, _, Just alrLayout) ->
2026                  do setAlrExpectingOCurly Nothing
2027                     let isLet = case alrLayout of
2028                                 ALRLayoutLet -> True
2029                                 _ -> False
2030                     setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)
2031                     return t
2032              -- ...and makes this case unnecessary
2033              {-
2034              -- I think our implicit open-curly handling is slightly
2035              -- different to John's, in how it interacts with newlines
2036              -- and "in"
2037              (ITocurly, _, Just _) ->
2038                  do setAlrExpectingOCurly Nothing
2039                     setNextToken t
2040                     lexTokenAlr
2041              -}
2042              (_, ALRLayout _ col : ls, Just expectingOCurly)
2043               | (thisCol > col) ||
2044                 (thisCol == col &&
2045                  isNonDecreasingIntentation expectingOCurly) ->
2046                  do setAlrExpectingOCurly Nothing
2047                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2048                     setNextToken t
2049                     return (L thisLoc ITocurly)
2050               | otherwise ->
2051                  do setAlrExpectingOCurly Nothing
2052                     setPendingImplicitTokens [L lastLoc ITccurly]
2053                     setNextToken t
2054                     return (L lastLoc ITocurly)
2055              (_, _, Just expectingOCurly) ->
2056                  do setAlrExpectingOCurly Nothing
2057                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2058                     setNextToken t
2059                     return (L thisLoc ITocurly)
2060              -- We do the [] cases earlier than in the spec, as we
2061              -- have an actual EOF token
2062              (ITeof, ALRLayout _ _ : ls, _) ->
2063                  do setALRContext ls
2064                     setNextToken t
2065                     return (L thisLoc ITccurly)
2066              (ITeof, _, _) ->
2067                  return t
2068              -- the other ITeof case omitted; general case below covers it
2069              (ITin, _, _)
2070               | justClosedExplicitLetBlock ->
2071                  return t
2072              (ITin, ALRLayout ALRLayoutLet _ : ls, _)
2073               | newLine ->
2074                  do setPendingImplicitTokens [t]
2075                     setALRContext ls
2076                     return (L thisLoc ITccurly)
2077              -- This next case is to handle a transitional issue:
2078              (ITwhere, ALRLayout _ col : ls, _)
2079               | newLine && thisCol == col && transitional ->
2080                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2081                                thisLoc
2082                                (transitionalAlternativeLayoutWarning
2083                                     "`where' clause at the same depth as implicit layout block")
2084                     setALRContext ls
2085                     setNextToken t
2086                     -- Note that we use lastLoc, as we may need to close
2087                     -- more layouts, or give a semicolon
2088                     return (L lastLoc ITccurly)
2089              -- This next case is to handle a transitional issue:
2090              (ITvbar, ALRLayout _ col : ls, _)
2091               | newLine && thisCol == col && transitional ->
2092                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2093                                thisLoc
2094                                (transitionalAlternativeLayoutWarning
2095                                     "`|' at the same depth as implicit layout block")
2096                     setALRContext ls
2097                     setNextToken t
2098                     -- Note that we use lastLoc, as we may need to close
2099                     -- more layouts, or give a semicolon
2100                     return (L lastLoc ITccurly)
2101              (_, ALRLayout _ col : ls, _)
2102               | newLine && thisCol == col ->
2103                  do setNextToken t
2104                     return (L thisLoc ITsemi)
2105               | newLine && thisCol < col ->
2106                  do setALRContext ls
2107                     setNextToken t
2108                     -- Note that we use lastLoc, as we may need to close
2109                     -- more layouts, or give a semicolon
2110                     return (L lastLoc ITccurly)
2111              -- We need to handle close before open, as 'then' is both
2112              -- an open and a close
2113              (u, _, _)
2114               | isALRclose u ->
2115                  case context of
2116                  ALRLayout _ _ : ls ->
2117                      do setALRContext ls
2118                         setNextToken t
2119                         return (L thisLoc ITccurly)
2120                  ALRNoLayout _ isLet : ls ->
2121                      do let ls' = if isALRopen u
2122                                      then ALRNoLayout (containsCommas u) False : ls
2123                                      else ls
2124                         setALRContext ls'
2125                         when isLet $ setJustClosedExplicitLetBlock True
2126                         return t
2127                  [] ->
2128                      do let ls = if isALRopen u
2129                                     then [ALRNoLayout (containsCommas u) False]
2130                                     else ls
2131                         setALRContext ls
2132                         -- XXX This is an error in John's code, but
2133                         -- it looks reachable to me at first glance
2134                         return t
2135              (u, _, _)
2136               | isALRopen u ->
2137                  do setALRContext (ALRNoLayout (containsCommas u) False : context)
2138                     return t
2139              (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->
2140                  do setALRContext ls
2141                     setPendingImplicitTokens [t]
2142                     return (L thisLoc ITccurly)
2143              (ITin, ALRLayout _ _ : ls, _) ->
2144                  do setALRContext ls
2145                     setNextToken t
2146                     return (L thisLoc ITccurly)
2147              -- the other ITin case omitted; general case below covers it
2148              (ITcomma, ALRLayout _ _ : ls, _)
2149               | topNoLayoutContainsCommas ls ->
2150                  do setALRContext ls
2151                     setNextToken t
2152                     return (L thisLoc ITccurly)
2153              (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->
2154                  do setALRContext ls
2155                     setPendingImplicitTokens [t]
2156                     return (L thisLoc ITccurly)
2157              -- the other ITwhere case omitted; general case below covers it
2158              (_, _, _) -> return t
2159
2160 transitionalAlternativeLayoutWarning :: String -> SDoc
2161 transitionalAlternativeLayoutWarning msg
2162     = text "transitional layout will not be accepted in the future:"
2163    $$ text msg
2164
2165 isALRopen :: Token -> Bool
2166 isALRopen ITcase        = True
2167 isALRopen ITif          = True
2168 isALRopen ITthen        = True
2169 isALRopen IToparen      = True
2170 isALRopen ITobrack      = True
2171 isALRopen ITocurly      = True
2172 -- GHC Extensions:
2173 isALRopen IToubxparen   = True
2174 isALRopen ITparenEscape = True
2175 isALRopen _             = False
2176
2177 isALRclose :: Token -> Bool
2178 isALRclose ITof     = True
2179 isALRclose ITthen   = True
2180 isALRclose ITelse   = True
2181 isALRclose ITcparen = True
2182 isALRclose ITcbrack = True
2183 isALRclose ITccurly = True
2184 -- GHC Extensions:
2185 isALRclose ITcubxparen = True
2186 isALRclose _        = False
2187
2188 isNonDecreasingIntentation :: ALRLayout -> Bool
2189 isNonDecreasingIntentation ALRLayoutDo = True
2190 isNonDecreasingIntentation _           = False
2191
2192 containsCommas :: Token -> Bool
2193 containsCommas IToparen = True
2194 containsCommas ITobrack = True
2195 -- John doesn't have {} as containing commas, but records contain them,
2196 -- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs
2197 -- (defaultInstallDirs).
2198 containsCommas ITocurly = True
2199 -- GHC Extensions:
2200 containsCommas IToubxparen = True
2201 containsCommas _        = False
2202
2203 topNoLayoutContainsCommas :: [ALRContext] -> Bool
2204 topNoLayoutContainsCommas [] = False
2205 topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
2206 topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
2207
2208 lexToken :: P (Located Token)
2209 lexToken = do
2210   inp@(AI loc1 buf) <- getInput
2211   sc <- getLexState
2212   exts <- getExts
2213   case alexScanUser exts inp sc of
2214     AlexEOF -> do
2215         let span = mkSrcSpan loc1 loc1
2216         setLastToken span 0
2217         return (L span ITeof)
2218     AlexError (AI loc2 buf) ->
2219         reportLexError loc1 loc2 buf "lexical error"
2220     AlexSkip inp2 _ -> do
2221         setInput inp2
2222         lexToken
2223     AlexToken inp2@(AI end buf2) _ t -> do
2224         setInput inp2
2225         let span = mkSrcSpan loc1 end
2226         let bytes = byteDiff buf buf2
2227         span `seq` setLastToken span bytes
2228         t span buf bytes
2229
2230 reportLexError :: SrcLoc -> SrcLoc -> StringBuffer -> [Char] -> P a
2231 reportLexError loc1 loc2 buf str
2232   | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
2233   | otherwise =
2234   let
2235         c = fst (nextChar buf)
2236   in
2237   if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
2238     then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
2239     else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
2240
2241 lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token]
2242 lexTokenStream buf loc dflags = unP go initState
2243     where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
2244           initState = mkPState dflags' buf loc
2245           go = do
2246             ltok <- lexer return
2247             case ltok of
2248               L _ ITeof -> return []
2249               _ -> liftM (ltok:) go
2250
2251 linePrags = Map.singleton "line" (begin line_prag2)
2252
2253 fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),
2254                                  ("options_ghc", lex_string_prag IToptions_prag),
2255                                  ("options_haddock", lex_string_prag ITdocOptions),
2256                                  ("language", token ITlanguage_prag),
2257                                  ("include", lex_string_prag ITinclude_prag)])
2258
2259 ignoredPrags = Map.fromList (map ignored pragmas)
2260                where ignored opt = (opt, nested_comment lexToken)
2261                      impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]
2262                      options_pragmas = map ("options_" ++) impls
2263                      -- CFILES is a hugs-only thing.
2264                      pragmas = options_pragmas ++ ["cfiles", "contract"]
2265
2266 oneWordPrags = Map.fromList([("rules", rulePrag),
2267                            ("inline", token (ITinline_prag Inline FunLike)),
2268                            ("inlinable", token (ITinline_prag Inlinable FunLike)),
2269                            ("inlineable", token (ITinline_prag Inlinable FunLike)),
2270                                           -- Spelling variant
2271                            ("notinline", token (ITinline_prag NoInline FunLike)),
2272                            ("specialize", token ITspec_prag),
2273                            ("source", token ITsource_prag),
2274                            ("warning", token ITwarning_prag),
2275                            ("deprecated", token ITdeprecated_prag),
2276                            ("scc", token ITscc_prag),
2277                            ("generated", token ITgenerated_prag),
2278                            ("core", token ITcore_prag),
2279                            ("unpack", token ITunpack_prag),
2280                            ("ann", token ITann_prag),
2281                            ("vectorize", token ITvect_prag)])
2282
2283 twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
2284                              ("notinline conlike", token (ITinline_prag NoInline ConLike)),
2285                              ("specialize inline", token (ITspec_inline_prag True)),
2286                              ("specialize notinline", token (ITspec_inline_prag False)),
2287                              ("vectorize scalar", token ITvect_scalar_prag)])
2288
2289 dispatch_pragmas :: Map String Action -> Action
2290 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
2291                                        Just found -> found span buf len
2292                                        Nothing -> lexError "unknown pragma"
2293
2294 known_pragma :: Map String Action -> AlexAccPred Int
2295 known_pragma prags _ _ len (AI _ buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags)
2296                                           && (nextCharIs buf (\c -> not (isAlphaNum c || c == '_')))
2297
2298 clean_pragma :: String -> String
2299 clean_pragma prag = canon_ws (map toLower (unprefix prag))
2300                     where unprefix prag' = case stripPrefix "{-#" prag' of
2301                                              Just rest -> rest
2302                                              Nothing -> prag'
2303                           canonical prag' = case prag' of
2304                                               "noinline" -> "notinline"
2305                                               "specialise" -> "specialize"
2306                                               "vectorise" -> "vectorize"
2307                                               "constructorlike" -> "conlike"
2308                                               _ -> prag'
2309                           canon_ws s = unwords (map canonical (words s))
2310 }