The Backpack patch.
[ghc.git] / compiler / parser / Lexer.x
1 -----------------------------------------------------------------------------
2 -- (c) The University of Glasgow, 2006
3 --
4 -- GHC's lexer for Haskell 2010 [1].
5 --
6 -- This is a combination of an Alex-generated lexer [2] from a regex
7 -- definition, with some hand-coded bits. [3]
8 --
9 -- Completely accurate information about token-spans within the source
10 -- file is maintained.  Every token has a start and end RealSrcLoc
11 -- attached to it.
12 --
13 -- References:
14 -- [1] https://www.haskell.org/onlinereport/haskell2010/haskellch2.html
15 -- [2] http://www.haskell.org/alex/
16 -- [3] https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/Parser
17 --
18 -----------------------------------------------------------------------------
19
20 --   ToDo / known bugs:
21 --    - parsing integers is a bit slow
22 --    - readRational is a bit slow
23 --
24 --   Known bugs, that were also in the previous version:
25 --    - M... should be 3 tokens, not 1.
26 --    - pragma-end should be only valid in a pragma
27
28 --   qualified operator NOTES.
29 --
30 --   - If M.(+) is a single lexeme, then..
31 --     - Probably (+) should be a single lexeme too, for consistency.
32 --       Otherwise ( + ) would be a prefix operator, but M.( + ) would not be.
33 --     - But we have to rule out reserved operators, otherwise (..) becomes
34 --       a different lexeme.
35 --     - Should we therefore also rule out reserved operators in the qualified
36 --       form?  This is quite difficult to achieve.  We don't do it for
37 --       qualified varids.
38
39
40 -- -----------------------------------------------------------------------------
41 -- Alex "Haskell code fragment top"
42
43 {
44 {-# LANGUAGE BangPatterns #-}
45
46 -- See Note [Warnings in code generated by Alex] in compiler/parser/Lexer.x
47 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
48 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
49 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
50 {-# OPTIONS_GHC -fno-warn-tabs #-}
51 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
52
53 {-# OPTIONS_GHC -funbox-strict-fields #-}
54
55 module Lexer (
56    Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
57    P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getSrcLoc,
58    getPState, extopt, withThisPackage,
59    failLocMsgP, failSpanMsgP, srcParseFail,
60    getMessages,
61    popContext, pushModuleContext, setLastToken, setSrcLoc,
62    activeContext, nextIsEOF,
63    getLexState, popLexState, pushLexState,
64    extension, bangPatEnabled, datatypeContextsEnabled,
65    traditionalRecordSyntaxEnabled,
66    explicitForallEnabled,
67    inRulePrag,
68    explicitNamespacesEnabled,
69    patternSynonymsEnabled,
70    sccProfilingOn, hpcEnabled,
71    addWarning,
72    lexTokenStream,
73    addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
74    moveAnnotations
75   ) where
76
77 -- base
78 import Control.Monad
79 #if __GLASGOW_HASKELL__ > 710
80 import Control.Monad.Fail
81 #endif
82 import Data.Bits
83 import Data.Char
84 import Data.List
85 import Data.Maybe
86 import Data.Word
87
88 import Data.IntSet (IntSet)
89 import qualified Data.IntSet as IntSet
90
91 -- ghc-boot
92 import qualified GHC.LanguageExtensions as LangExt
93
94 -- bytestring
95 import Data.ByteString (ByteString)
96
97 -- containers
98 import Data.Map (Map)
99 import qualified Data.Map as Map
100
101 -- compiler/utils
102 import Bag
103 import Outputable
104 import StringBuffer
105 import FastString
106 import UniqFM
107 import Util             ( readRational )
108
109 -- compiler/main
110 import ErrUtils
111 import DynFlags
112
113 -- compiler/basicTypes
114 import SrcLoc
115 import Module
116 import BasicTypes     ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..),
117                         SourceText )
118
119 -- compiler/parser
120 import Ctype
121
122 import ApiAnnotation
123 }
124
125 -- -----------------------------------------------------------------------------
126 -- Alex "Character set macros"
127
128 -- NB: The logic behind these definitions is also reflected in basicTypes/Lexeme.hs
129 -- Any changes here should likely be reflected there.
130 $unispace    = \x05 -- Trick Alex into handling Unicode. See alexGetByte.
131 $nl          = [\n\r\f]
132 $whitechar   = [$nl\v\ $unispace]
133 $white_no_nl = $whitechar # \n -- TODO #8424
134 $tab         = \t
135
136 $ascdigit  = 0-9
137 $unidigit  = \x03 -- Trick Alex into handling Unicode. See alexGetByte.
138 $decdigit  = $ascdigit -- for now, should really be $digit (ToDo)
139 $digit     = [$ascdigit $unidigit]
140
141 $special   = [\(\)\,\;\[\]\`\{\}]
142 $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
143 $unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetByte.
144 $symbol    = [$ascsymbol $unisymbol] # [$special \_\"\']
145
146 $unilarge  = \x01 -- Trick Alex into handling Unicode. See alexGetByte.
147 $asclarge  = [A-Z]
148 $large     = [$asclarge $unilarge]
149
150 $unismall  = \x02 -- Trick Alex into handling Unicode. See alexGetByte.
151 $ascsmall  = [a-z]
152 $small     = [$ascsmall $unismall \_]
153
154 $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetByte.
155 $graphic   = [$small $large $symbol $digit $special $unigraphic \"\']
156
157 $binit     = 0-1
158 $octit     = 0-7
159 $hexit     = [$decdigit A-F a-f]
160
161 $uniidchar = \x07 -- Trick Alex into handling Unicode. See alexGetByte.
162 $idchar    = [$small $large $digit $uniidchar \']
163
164 $pragmachar = [$small $large $digit]
165
166 $docsym    = [\| \^ \* \$]
167
168
169 -- -----------------------------------------------------------------------------
170 -- Alex "Regular expression macros"
171
172 @varid     = $small $idchar*          -- variable identifiers
173 @conid     = $large $idchar*          -- constructor identifiers
174
175 @varsym    = ($symbol # \:) $symbol*  -- variable (operator) symbol
176 @consym    = \: $symbol*              -- constructor (operator) symbol
177
178 @decimal     = $decdigit+
179 @binary      = $binit+
180 @octal       = $octit+
181 @hexadecimal = $hexit+
182 @exponent    = [eE] [\-\+]? @decimal
183
184 @qual = (@conid \.)+
185 @qvarid = @qual @varid
186 @qconid = @qual @conid
187 @qvarsym = @qual @varsym
188 @qconsym = @qual @consym
189
190 @floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
191
192 -- normal signed numerical literals can only be explicitly negative,
193 -- not explicitly positive (contrast @exponent)
194 @negative = \-
195 @signed = @negative ?
196
197
198 -- -----------------------------------------------------------------------------
199 -- Alex "Identifier"
200
201 haskell :-
202
203
204 -- -----------------------------------------------------------------------------
205 -- Alex "Rules"
206
207 -- everywhere: skip whitespace
208 $white_no_nl+ ;
209 $tab          { warnTab }
210
211 -- Everywhere: deal with nested comments.  We explicitly rule out
212 -- pragmas, "{-#", so that we don't accidentally treat them as comments.
213 -- (this can happen even though pragmas will normally take precedence due to
214 -- longest-match, because pragmas aren't valid in every state, but comments
215 -- are). We also rule out nested Haddock comments, if the -haddock flag is
216 -- set.
217
218 "{-" / { isNormalComment } { nested_comment lexToken }
219
220 -- Single-line comments are a bit tricky.  Haskell 98 says that two or
221 -- more dashes followed by a symbol should be parsed as a varsym, so we
222 -- have to exclude those.
223
224 -- Since Haddock comments aren't valid in every state, we need to rule them
225 -- out here.
226
227 -- The following two rules match comments that begin with two dashes, but
228 -- continue with a different character. The rules test that this character
229 -- is not a symbol (in which case we'd have a varsym), and that it's not a
230 -- space followed by a Haddock comment symbol (docsym) (in which case we'd
231 -- have a Haddock comment). The rules then munch the rest of the line.
232
233 "-- " ~$docsym .* { lineCommentToken }
234 "--" [^$symbol \ ] .* { lineCommentToken }
235
236 -- Next, match Haddock comments if no -haddock flag
237
238 "-- " $docsym .* / { ifExtension (not . haddockEnabled) } { lineCommentToken }
239
240 -- Now, when we've matched comments that begin with 2 dashes and continue
241 -- with a different character, we need to match comments that begin with three
242 -- or more dashes (which clearly can't be Haddock comments). We only need to
243 -- make sure that the first non-dash character isn't a symbol, and munch the
244 -- rest of the line.
245
246 "---"\-* ~$symbol .* { lineCommentToken }
247
248 -- Since the previous rules all match dashes followed by at least one
249 -- character, we also need to match a whole line filled with just dashes.
250
251 "--"\-* / { atEOL } { lineCommentToken }
252
253 -- We need this rule since none of the other single line comment rules
254 -- actually match this case.
255
256 "-- " / { atEOL } { lineCommentToken }
257
258 -- 'bol' state: beginning of a line.  Slurp up all the whitespace (including
259 -- blank lines) until we find a non-whitespace character, then do layout
260 -- processing.
261 --
262 -- One slight wibble here: what if the line begins with {-#? In
263 -- theory, we have to lex the pragma to see if it's one we recognise,
264 -- and if it is, then we backtrack and do_bol, otherwise we treat it
265 -- as a nested comment.  We don't bother with this: if the line begins
266 -- with {-#, then we'll assume it's a pragma we know about and go for do_bol.
267 <bol> {
268   \n                                    ;
269   ^\# line                              { begin line_prag1 }
270   ^\# / { followedByDigit }             { begin line_prag1 }
271   ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently
272   ^\# \! .* \n                          ; -- #!, for scripts
273   ()                                    { do_bol }
274 }
275
276 -- after a layout keyword (let, where, do, of), we begin a new layout
277 -- context if the curly brace is missing.
278 -- Careful! This stuff is quite delicate.
279 <layout, layout_do, layout_if> {
280   \{ / { notFollowedBy '-' }            { hopefully_open_brace }
281         -- we might encounter {-# here, but {- has been handled already
282   \n                                    ;
283   ^\# (line)?                           { begin line_prag1 }
284 }
285
286 -- after an 'if', a vertical bar starts a layout context for MultiWayIf
287 <layout_if> {
288   \| / { notFollowedBySymbol }          { new_layout_context True dontGenerateSemic ITvbar }
289   ()                                    { pop }
290 }
291
292 -- do is treated in a subtly different way, see new_layout_context
293 <layout>    ()                          { new_layout_context True  generateSemic ITvocurly }
294 <layout_do> ()                          { new_layout_context False generateSemic ITvocurly }
295
296 -- after a new layout context which was found to be to the left of the
297 -- previous context, we have generated a '{' token, and we now need to
298 -- generate a matching '}' token.
299 <layout_left>  ()                       { do_layout_left }
300
301 <0,option_prags> \n                     { begin bol }
302
303 "{-#" $whitechar* $pragmachar+ / { known_pragma linePrags }
304                                 { dispatch_pragmas linePrags }
305
306 -- single-line line pragmas, of the form
307 --    # <line> "<file>" <extra-stuff> \n
308 <line_prag1> @decimal                   { setLine line_prag1a }
309 <line_prag1a> \" [$graphic \ ]* \"      { setFile line_prag1b }
310 <line_prag1b> .*                        { pop }
311
312 -- Haskell-style line pragmas, of the form
313 --    {-# LINE <line> "<file>" #-}
314 <line_prag2> @decimal                   { setLine line_prag2a }
315 <line_prag2a> \" [$graphic \ ]* \"      { setFile line_prag2b }
316 <line_prag2b> "#-}"|"-}"                { pop }
317    -- NOTE: accept -} at the end of a LINE pragma, for compatibility
318    -- with older versions of GHC which generated these.
319
320 <0,option_prags> {
321   "{-#" $whitechar* $pragmachar+
322         $whitechar+ $pragmachar+ / { known_pragma twoWordPrags }
323                                  { dispatch_pragmas twoWordPrags }
324
325   "{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags }
326                                  { dispatch_pragmas oneWordPrags }
327
328   -- We ignore all these pragmas, but don't generate a warning for them
329   "{-#" $whitechar* $pragmachar+ / { known_pragma ignoredPrags }
330                                  { dispatch_pragmas ignoredPrags }
331
332   -- ToDo: should only be valid inside a pragma:
333   "#-}"                          { endPrag }
334 }
335
336 <option_prags> {
337   "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }
338                                    { dispatch_pragmas fileHeaderPrags }
339 }
340
341 <0> {
342   -- In the "0" mode we ignore these pragmas
343   "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }
344                      { nested_comment lexToken }
345 }
346
347 <0,option_prags> {
348   "{-#"  { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma")
349                     (nested_comment lexToken) }
350 }
351
352 -- '0' state: ordinary lexemes
353
354 -- Haddock comments
355
356 <0,option_prags> {
357   "-- " $docsym      / { ifExtension haddockEnabled } { multiline_doc_comment }
358   "{-" \ ? $docsym   / { ifExtension haddockEnabled } { nested_doc_comment }
359 }
360
361 -- "special" symbols
362
363 <0> {
364   "[:" / { ifExtension parrEnabled }    { token ITopabrack }
365   ":]" / { ifExtension parrEnabled }    { token ITcpabrack }
366 }
367
368 <0> {
369   "[|"        / { ifExtension thQuotesEnabled } { token (ITopenExpQuote NoE
370                                                                 NormalSyntax) }
371   "[||"       / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote NoE) }
372   "[e|"       / { ifExtension thQuotesEnabled } { token (ITopenExpQuote HasE
373                                                                 NormalSyntax) }
374   "[e||"      / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote HasE) }
375   "[p|"       / { ifExtension thQuotesEnabled } { token ITopenPatQuote }
376   "[d|"       / { ifExtension thQuotesEnabled } { layout_token ITopenDecQuote }
377   "[t|"       / { ifExtension thQuotesEnabled } { token ITopenTypQuote }
378   "|]"        / { ifExtension thQuotesEnabled } { token (ITcloseQuote
379                                                                 NormalSyntax) }
380   "||]"       / { ifExtension thQuotesEnabled } { token ITcloseTExpQuote }
381   \$ @varid   / { ifExtension thEnabled } { skip_one_varid ITidEscape }
382   "$$" @varid / { ifExtension thEnabled } { skip_two_varid ITidTyEscape }
383   "$("        / { ifExtension thEnabled } { token ITparenEscape }
384   "$$("       / { ifExtension thEnabled } { token ITparenTyEscape }
385
386   "[" @varid "|"  / { ifExtension qqEnabled }
387                      { lex_quasiquote_tok }
388
389   -- qualified quasi-quote (#5555)
390   "[" @qvarid "|"  / { ifExtension qqEnabled }
391                      { lex_qquasiquote_tok }
392
393   $unigraphic -- ⟦
394     / { ifCurrentChar '⟦' `alexAndPred`
395         ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) }
396     { token (ITopenExpQuote NoE UnicodeSyntax) }
397   $unigraphic -- ⟧
398     / { ifCurrentChar '⟧' `alexAndPred`
399         ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) }
400     { token (ITcloseQuote UnicodeSyntax) }
401 }
402
403   -- See Note [Lexing type applications]
404 <0> {
405     [^ $idchar \) ] ^
406   "@"
407     / { ifExtension typeApplicationEnabled `alexAndPred` notFollowedBySymbol }
408     { token ITtypeApp }
409 }
410
411 <0> {
412   "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
413                                         { special (IToparenbar NormalSyntax) }
414   "|)" / { ifExtension arrowsEnabled }  { special (ITcparenbar NormalSyntax) }
415
416   $unigraphic -- ⦇
417     / { ifCurrentChar '⦇' `alexAndPred`
418         ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) }
419     { special (IToparenbar UnicodeSyntax) }
420   $unigraphic -- ⦈
421     / { ifCurrentChar '⦈' `alexAndPred`
422         ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) }
423     { special (ITcparenbar UnicodeSyntax) }
424 }
425
426 <0> {
427   \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
428 }
429
430 <0> {
431   "#" @varid / { ifExtension overloadedLabelsEnabled }
432                { skip_one_varid ITlabelvarid }
433 }
434
435 <0> {
436   "(#" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled }
437          { token IToubxparen }
438   "#)" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled }
439          { token ITcubxparen }
440 }
441
442 <0,option_prags> {
443   \(                                    { special IToparen }
444   \)                                    { special ITcparen }
445   \[                                    { special ITobrack }
446   \]                                    { special ITcbrack }
447   \,                                    { special ITcomma }
448   \;                                    { special ITsemi }
449   \`                                    { special ITbackquote }
450
451   \{                                    { open_brace }
452   \}                                    { close_brace }
453 }
454
455 <0,option_prags> {
456   @qvarid                       { idtoken qvarid }
457   @qconid                       { idtoken qconid }
458   @varid                        { varid }
459   @conid                        { idtoken conid }
460 }
461
462 <0> {
463   @qvarid "#"+      / { ifExtension magicHashEnabled } { idtoken qvarid }
464   @qconid "#"+      / { ifExtension magicHashEnabled } { idtoken qconid }
465   @varid "#"+       / { ifExtension magicHashEnabled } { varid }
466   @conid "#"+       / { ifExtension magicHashEnabled } { idtoken conid }
467 }
468
469 -- ToDo: - move `var` and (sym) into lexical syntax?
470 --       - remove backquote from $special?
471 <0> {
472   @qvarsym                                         { idtoken qvarsym }
473   @qconsym                                         { idtoken qconsym }
474   @varsym                                          { varsym }
475   @consym                                          { consym }
476 }
477
478 -- For the normal boxed literals we need to be careful
479 -- when trying to be close to Haskell98
480 <0> {
481   -- Normal integral literals (:: Num a => a, from Integer)
482   @decimal                                                               { tok_num positive 0 0 decimal }
483   0[bB] @binary                / { ifExtension binaryLiteralsEnabled }   { tok_num positive 2 2 binary }
484   0[oO] @octal                                                           { tok_num positive 2 2 octal }
485   0[xX] @hexadecimal                                                     { tok_num positive 2 2 hexadecimal }
486   @negative @decimal           / { ifExtension negativeLiteralsEnabled } { tok_num negative 1 1 decimal }
487   @negative 0[bB] @binary      / { ifExtension negativeLiteralsEnabled `alexAndPred`
488                                    ifExtension binaryLiteralsEnabled }   { tok_num negative 3 3 binary }
489   @negative 0[oO] @octal       / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 octal }
490   @negative 0[xX] @hexadecimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 hexadecimal }
491
492   -- Normal rational literals (:: Fractional a => a, from Rational)
493   @floating_point                                                        { strtoken tok_float }
494   @negative @floating_point    / { ifExtension negativeLiteralsEnabled } { strtoken tok_float }
495 }
496
497 <0> {
498   -- Unboxed ints (:: Int#) and words (:: Word#)
499   -- It's simpler (and faster?) to give separate cases to the negatives,
500   -- especially considering octal/hexadecimal prefixes.
501   @decimal                     \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
502   0[bB] @binary                \# / { ifExtension magicHashEnabled `alexAndPred`
503                                       ifExtension binaryLiteralsEnabled } { tok_primint positive 2 3 binary }
504   0[oO] @octal                 \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
505   0[xX] @hexadecimal           \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
506   @negative @decimal           \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
507   @negative 0[bB] @binary      \# / { ifExtension magicHashEnabled `alexAndPred`
508                                       ifExtension binaryLiteralsEnabled } { tok_primint negative 3 4 binary }
509   @negative 0[oO] @octal       \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
510   @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
511
512   @decimal                     \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal }
513   0[bB] @binary                \# \# / { ifExtension magicHashEnabled `alexAndPred`
514                                          ifExtension binaryLiteralsEnabled } { tok_primword 2 4 binary }
515   0[oO] @octal                 \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }
516   0[xX] @hexadecimal           \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }
517
518   -- Unboxed floats and doubles (:: Float#, :: Double#)
519   -- prim_{float,double} work with signed literals
520   @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }
521   @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble }
522 }
523
524 -- Strings and chars are lexed by hand-written code.  The reason is
525 -- that even if we recognise the string or char here in the regex
526 -- lexer, we would still have to parse the string afterward in order
527 -- to convert it to a String.
528 <0> {
529   \'                            { lex_char_tok }
530   \"                            { lex_string_tok }
531 }
532
533 -- Note [Lexing type applications]
534 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
535 -- The desired syntax for type applications is to prefix the type application
536 -- with '@', like this:
537 --
538 --   foo @Int @Bool baz bum
539 --
540 -- This, of course, conflicts with as-patterns. The conflict arises because
541 -- expressions and patterns use the same parser, and also because we want
542 -- to allow type patterns within expression patterns.
543 --
544 -- Disambiguation is accomplished by requiring *something* to appear between
545 -- type application and the preceding token. This something must end with
546 -- a character that cannot be the end of the variable bound in an as-pattern.
547 -- Currently (June 2015), this means that the something cannot end with a
548 -- $idchar or a close-paren. (The close-paren is necessary if the as-bound
549 -- identifier is symbolic.)
550 --
551 -- Note that looking for whitespace before the '@' is insufficient, because
552 -- of this pathological case:
553 --
554 --   foo {- hi -}@Int
555 --
556 -- This design is predicated on the fact that as-patterns are generally
557 -- whitespace-free, and also that this whole thing is opt-in, with the
558 -- TypeApplications extension.
559
560 -- -----------------------------------------------------------------------------
561 -- Alex "Haskell code fragment bottom"
562
563 {
564
565 -- -----------------------------------------------------------------------------
566 -- The token type
567
568 data Token
569   = ITas                        -- Haskell keywords
570   | ITcase
571   | ITclass
572   | ITdata
573   | ITdefault
574   | ITderiving
575   | ITdo
576   | ITelse
577   | IThiding
578   | ITforeign
579   | ITif
580   | ITimport
581   | ITin
582   | ITinfix
583   | ITinfixl
584   | ITinfixr
585   | ITinstance
586   | ITlet
587   | ITmodule
588   | ITnewtype
589   | ITof
590   | ITqualified
591   | ITthen
592   | ITtype
593   | ITwhere
594
595   | ITforall            IsUnicodeSyntax -- GHC extension keywords
596   | ITexport
597   | ITlabel
598   | ITdynamic
599   | ITsafe
600   | ITinterruptible
601   | ITunsafe
602   | ITstdcallconv
603   | ITccallconv
604   | ITcapiconv
605   | ITprimcallconv
606   | ITjavascriptcallconv
607   | ITmdo
608   | ITfamily
609   | ITrole
610   | ITgroup
611   | ITby
612   | ITusing
613   | ITpattern
614   | ITstatic
615   | ITstock
616   | ITanyclass
617
618   -- Backpack tokens
619   | ITunit
620   | ITsignature
621   | ITdependency
622   | ITrequires
623
624   -- Pragmas, see  note [Pragma source text] in BasicTypes
625   | ITinline_prag       SourceText InlineSpec RuleMatchInfo
626   | ITspec_prag         SourceText                -- SPECIALISE
627   | ITspec_inline_prag  SourceText Bool    -- SPECIALISE INLINE (or NOINLINE)
628   | ITsource_prag       SourceText
629   | ITrules_prag        SourceText
630   | ITwarning_prag      SourceText
631   | ITdeprecated_prag   SourceText
632   | ITline_prag
633   | ITscc_prag          SourceText
634   | ITgenerated_prag    SourceText
635   | ITcore_prag         SourceText         -- hdaume: core annotations
636   | ITunpack_prag       SourceText
637   | ITnounpack_prag     SourceText
638   | ITann_prag          SourceText
639   | ITclose_prag
640   | IToptions_prag String
641   | ITinclude_prag String
642   | ITlanguage_prag
643   | ITvect_prag         SourceText
644   | ITvect_scalar_prag  SourceText
645   | ITnovect_prag       SourceText
646   | ITminimal_prag      SourceText
647   | IToverlappable_prag SourceText  -- instance overlap mode
648   | IToverlapping_prag  SourceText  -- instance overlap mode
649   | IToverlaps_prag     SourceText  -- instance overlap mode
650   | ITincoherent_prag   SourceText  -- instance overlap mode
651   | ITctype             SourceText
652
653   | ITdotdot                    -- reserved symbols
654   | ITcolon
655   | ITdcolon            IsUnicodeSyntax
656   | ITequal
657   | ITlam
658   | ITlcase
659   | ITvbar
660   | ITlarrow            IsUnicodeSyntax
661   | ITrarrow            IsUnicodeSyntax
662   | ITat
663   | ITtilde
664   | ITtildehsh
665   | ITdarrow            IsUnicodeSyntax
666   | ITminus
667   | ITbang
668   | ITdot
669
670   | ITbiglam                    -- GHC-extension symbols
671
672   | ITocurly                    -- special symbols
673   | ITccurly
674   | ITvocurly
675   | ITvccurly
676   | ITobrack
677   | ITopabrack                  -- [:, for parallel arrays with -XParallelArrays
678   | ITcpabrack                  -- :], for parallel arrays with -XParallelArrays
679   | ITcbrack
680   | IToparen
681   | ITcparen
682   | IToubxparen
683   | ITcubxparen
684   | ITsemi
685   | ITcomma
686   | ITunderscore
687   | ITbackquote
688   | ITsimpleQuote               --  '
689
690   | ITvarid   FastString        -- identifiers
691   | ITconid   FastString
692   | ITvarsym  FastString
693   | ITconsym  FastString
694   | ITqvarid  (FastString,FastString)
695   | ITqconid  (FastString,FastString)
696   | ITqvarsym (FastString,FastString)
697   | ITqconsym (FastString,FastString)
698
699   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
700   | ITlabelvarid   FastString   -- Overloaded label: #x
701
702   | ITchar     SourceText Char       -- Note [Literal source text] in BasicTypes
703   | ITstring   SourceText FastString -- Note [Literal source text] in BasicTypes
704   | ITinteger  SourceText Integer    -- Note [Literal source text] in BasicTypes
705   | ITrational FractionalLit
706
707   | ITprimchar   SourceText Char     -- Note [Literal source text] in BasicTypes
708   | ITprimstring SourceText ByteString -- Note [Literal source text] @BasicTypes
709   | ITprimint    SourceText Integer  -- Note [Literal source text] in BasicTypes
710   | ITprimword   SourceText Integer  -- Note [Literal source text] in BasicTypes
711   | ITprimfloat  FractionalLit
712   | ITprimdouble FractionalLit
713
714   -- Template Haskell extension tokens
715   | ITopenExpQuote HasE IsUnicodeSyntax --  [| or [e|
716   | ITopenPatQuote                      --  [p|
717   | ITopenDecQuote                      --  [d|
718   | ITopenTypQuote                      --  [t|
719   | ITcloseQuote IsUnicodeSyntax        --  |]
720   | ITopenTExpQuote HasE                --  [|| or [e||
721   | ITcloseTExpQuote                    --  ||]
722   | ITidEscape   FastString             --  $x
723   | ITparenEscape                       --  $(
724   | ITidTyEscape   FastString           --  $$x
725   | ITparenTyEscape                     --  $$(
726   | ITtyQuote                           --  ''
727   | ITquasiQuote (FastString,FastString,RealSrcSpan)
728     -- ITquasiQuote(quoter, quote, loc)
729     -- represents a quasi-quote of the form
730     -- [quoter| quote |]
731   | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan)
732     -- ITqQuasiQuote(Qual, quoter, quote, loc)
733     -- represents a qualified quasi-quote of the form
734     -- [Qual.quoter| quote |]
735
736   -- Arrow notation extension
737   | ITproc
738   | ITrec
739   | IToparenbar  IsUnicodeSyntax --  (|
740   | ITcparenbar  IsUnicodeSyntax --  |)
741   | ITlarrowtail IsUnicodeSyntax --  -<
742   | ITrarrowtail IsUnicodeSyntax --  >-
743   | ITLarrowtail IsUnicodeSyntax --  -<<
744   | ITRarrowtail IsUnicodeSyntax --  >>-
745
746   -- type application '@' (lexed differently than as-pattern '@',
747   -- due to checking for preceding whitespace)
748   | ITtypeApp
749
750
751   | ITunknown String            -- Used when the lexer can't make sense of it
752   | ITeof                       -- end of file token
753
754   -- Documentation annotations
755   | ITdocCommentNext  String     -- something beginning '-- |'
756   | ITdocCommentPrev  String     -- something beginning '-- ^'
757   | ITdocCommentNamed String     -- something beginning '-- $'
758   | ITdocSection      Int String -- a section heading
759   | ITdocOptions      String     -- doc options (prune, ignore-exports, etc)
760   | ITlineComment     String     -- comment starting by "--"
761   | ITblockComment    String     -- comment in {- -}
762
763   deriving Show
764
765 instance Outputable Token where
766   ppr x = text (show x)
767
768
769 -- the bitmap provided as the third component indicates whether the
770 -- corresponding extension keyword is valid under the extension options
771 -- provided to the compiler; if the extension corresponding to *any* of the
772 -- bits set in the bitmap is enabled, the keyword is valid (this setup
773 -- facilitates using a keyword in two different extensions that can be
774 -- activated independently)
775 --
776 reservedWordsFM :: UniqFM (Token, ExtsBitmap)
777 reservedWordsFM = listToUFM $
778     map (\(x, y, z) -> (mkFastString x, (y, z)))
779         [( "_",              ITunderscore,    0 ),
780          ( "as",             ITas,            0 ),
781          ( "case",           ITcase,          0 ),
782          ( "class",          ITclass,         0 ),
783          ( "data",           ITdata,          0 ),
784          ( "default",        ITdefault,       0 ),
785          ( "deriving",       ITderiving,      0 ),
786          ( "do",             ITdo,            0 ),
787          ( "else",           ITelse,          0 ),
788          ( "hiding",         IThiding,        0 ),
789          ( "if",             ITif,            0 ),
790          ( "import",         ITimport,        0 ),
791          ( "in",             ITin,            0 ),
792          ( "infix",          ITinfix,         0 ),
793          ( "infixl",         ITinfixl,        0 ),
794          ( "infixr",         ITinfixr,        0 ),
795          ( "instance",       ITinstance,      0 ),
796          ( "let",            ITlet,           0 ),
797          ( "module",         ITmodule,        0 ),
798          ( "newtype",        ITnewtype,       0 ),
799          ( "of",             ITof,            0 ),
800          ( "qualified",      ITqualified,     0 ),
801          ( "then",           ITthen,          0 ),
802          ( "type",           ITtype,          0 ),
803          ( "where",          ITwhere,         0 ),
804
805          ( "forall",         ITforall NormalSyntax,
806                                               xbit ExplicitForallBit .|.
807                                               xbit InRulePragBit),
808          ( "mdo",            ITmdo,           xbit RecursiveDoBit),
809              -- See Note [Lexing type pseudo-keywords]
810          ( "family",         ITfamily,        0 ),
811          ( "role",           ITrole,          0 ),
812          ( "pattern",        ITpattern,       xbit PatternSynonymsBit),
813          ( "static",         ITstatic,        0 ),
814          ( "stock",          ITstock,         0 ),
815          ( "anyclass",       ITanyclass,      0 ),
816          ( "group",          ITgroup,         xbit TransformComprehensionsBit),
817          ( "by",             ITby,            xbit TransformComprehensionsBit),
818          ( "using",          ITusing,         xbit TransformComprehensionsBit),
819
820          ( "foreign",        ITforeign,       xbit FfiBit),
821          ( "export",         ITexport,        xbit FfiBit),
822          ( "label",          ITlabel,         xbit FfiBit),
823          ( "dynamic",        ITdynamic,       xbit FfiBit),
824          ( "safe",           ITsafe,          xbit FfiBit .|.
825                                               xbit SafeHaskellBit),
826          ( "interruptible",  ITinterruptible, xbit InterruptibleFfiBit),
827          ( "unsafe",         ITunsafe,        xbit FfiBit),
828          ( "stdcall",        ITstdcallconv,   xbit FfiBit),
829          ( "ccall",          ITccallconv,     xbit FfiBit),
830          ( "capi",           ITcapiconv,      xbit CApiFfiBit),
831          ( "prim",           ITprimcallconv,  xbit FfiBit),
832          ( "javascript",     ITjavascriptcallconv, xbit FfiBit),
833
834          ( "unit",           ITunit,          0 ),
835          ( "dependency",     ITdependency,       0 ),
836          ( "signature",      ITsignature,     0 ),
837
838          ( "rec",            ITrec,           xbit ArrowsBit .|.
839                                               xbit RecursiveDoBit),
840          ( "proc",           ITproc,          xbit ArrowsBit)
841      ]
842
843 {-----------------------------------
844 Note [Lexing type pseudo-keywords]
845 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
846
847 One might think that we wish to treat 'family' and 'role' as regular old
848 varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively.
849 But, there is no need to do so. These pseudo-keywords are not stolen syntax:
850 they are only used after the keyword 'type' at the top-level, where varids are
851 not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that
852 type families and role annotations are never declared without their extensions
853 on. In fact, by unconditionally lexing these pseudo-keywords as special, we
854 can get better error messages.
855
856 Also, note that these are included in the `varid` production in the parser --
857 a key detail to make all this work.
858 -------------------------------------}
859
860 reservedSymsFM :: UniqFM (Token, ExtsBitmap -> Bool)
861 reservedSymsFM = listToUFM $
862     map (\ (x,y,z) -> (mkFastString x,(y,z)))
863       [ ("..",  ITdotdot,              always)
864         -- (:) is a reserved op, meaning only list cons
865        ,(":",   ITcolon,               always)
866        ,("::",  ITdcolon NormalSyntax, always)
867        ,("=",   ITequal,               always)
868        ,("\\",  ITlam,                 always)
869        ,("|",   ITvbar,                always)
870        ,("<-",  ITlarrow NormalSyntax, always)
871        ,("->",  ITrarrow NormalSyntax, always)
872        ,("@",   ITat,                  always)
873        ,("~",   ITtilde,               always)
874        ,("~#",  ITtildehsh,            magicHashEnabled)
875        ,("=>",  ITdarrow NormalSyntax, always)
876        ,("-",   ITminus,               always)
877        ,("!",   ITbang,                always)
878
879         -- For 'forall a . t'
880        ,(".", ITdot,  always) -- \i -> explicitForallEnabled i || inRulePrag i)
881
882        ,("-<",  ITlarrowtail NormalSyntax, arrowsEnabled)
883        ,(">-",  ITrarrowtail NormalSyntax, arrowsEnabled)
884        ,("-<<", ITLarrowtail NormalSyntax, arrowsEnabled)
885        ,(">>-", ITRarrowtail NormalSyntax, arrowsEnabled)
886
887        ,("∷",   ITdcolon UnicodeSyntax, unicodeSyntaxEnabled)
888        ,("⇒",   ITdarrow UnicodeSyntax, unicodeSyntaxEnabled)
889        ,("∀",   ITforall UnicodeSyntax, unicodeSyntaxEnabled)
890        ,("→",   ITrarrow UnicodeSyntax, unicodeSyntaxEnabled)
891        ,("←",   ITlarrow UnicodeSyntax, unicodeSyntaxEnabled)
892
893        ,("⤙",   ITlarrowtail UnicodeSyntax,
894                                 \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
895        ,("⤚",   ITrarrowtail UnicodeSyntax,
896                                 \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
897        ,("⤛",   ITLarrowtail UnicodeSyntax,
898                                 \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
899        ,("⤜",   ITRarrowtail UnicodeSyntax,
900                                 \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
901
902         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
903         -- form part of a large operator.  This would let us have a better
904         -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
905        ]
906
907 -- -----------------------------------------------------------------------------
908 -- Lexer actions
909
910 type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token)
911
912 special :: Token -> Action
913 special tok span _buf _len = return (L span tok)
914
915 token, layout_token :: Token -> Action
916 token t span _buf _len = return (L span t)
917 layout_token t span _buf _len = pushLexState layout >> return (L span t)
918
919 idtoken :: (StringBuffer -> Int -> Token) -> Action
920 idtoken f span buf len = return (L span $! (f buf len))
921
922 skip_one_varid :: (FastString -> Token) -> Action
923 skip_one_varid f span buf len
924   = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
925
926 skip_two_varid :: (FastString -> Token) -> Action
927 skip_two_varid f span buf len
928   = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2)))
929
930 strtoken :: (String -> Token) -> Action
931 strtoken f span buf len =
932   return (L span $! (f $! lexemeToString buf len))
933
934 init_strtoken :: Int -> (String -> Token) -> Action
935 -- like strtoken, but drops the last N character(s)
936 init_strtoken drop f span buf len =
937   return (L span $! (f $! lexemeToString buf (len-drop)))
938
939 begin :: Int -> Action
940 begin code _span _str _len = do pushLexState code; lexToken
941
942 pop :: Action
943 pop _span _buf _len = do _ <- popLexState
944                          lexToken
945
946 hopefully_open_brace :: Action
947 hopefully_open_brace span buf len
948  = do relaxed <- extension relaxedLayout
949       ctx <- getContext
950       (AI l _) <- getInput
951       let offset = srcLocCol l
952           isOK = relaxed ||
953                  case ctx of
954                  Layout prev_off _ : _ -> prev_off < offset
955                  _                     -> True
956       if isOK then pop_and open_brace span buf len
957               else failSpanMsgP (RealSrcSpan span) (text "Missing block")
958
959 pop_and :: Action -> Action
960 pop_and act span buf len = do _ <- popLexState
961                               act span buf len
962
963 {-# INLINE nextCharIs #-}
964 nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool
965 nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
966
967 {-# INLINE nextCharIsNot #-}
968 nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool
969 nextCharIsNot buf p = not (nextCharIs buf p)
970
971 notFollowedBy :: Char -> AlexAccPred ExtsBitmap
972 notFollowedBy char _ _ _ (AI _ buf)
973   = nextCharIsNot buf (== char)
974
975 notFollowedBySymbol :: AlexAccPred ExtsBitmap
976 notFollowedBySymbol _ _ _ (AI _ buf)
977   = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~")
978
979 followedByDigit :: AlexAccPred ExtsBitmap
980 followedByDigit _ _ _ (AI _ buf)
981   = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9']))
982
983 ifCurrentChar :: Char -> AlexAccPred ExtsBitmap
984 ifCurrentChar char _ (AI _ buf) _ _
985   = nextCharIs buf (== char)
986
987 -- We must reject doc comments as being ordinary comments everywhere.
988 -- In some cases the doc comment will be selected as the lexeme due to
989 -- maximal munch, but not always, because the nested comment rule is
990 -- valid in all states, but the doc-comment rules are only valid in
991 -- the non-layout states.
992 isNormalComment :: AlexAccPred ExtsBitmap
993 isNormalComment bits _ _ (AI _ buf)
994   | haddockEnabled bits = notFollowedByDocOrPragma
995   | otherwise           = nextCharIsNot buf (== '#')
996   where
997     notFollowedByDocOrPragma
998        = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#"))
999
1000 afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool
1001 afterOptionalSpace buf p
1002     = if nextCharIs buf (== ' ')
1003       then p (snd (nextChar buf))
1004       else p buf
1005
1006 atEOL :: AlexAccPred ExtsBitmap
1007 atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'
1008
1009 ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap
1010 ifExtension pred bits _ _ _ = pred bits
1011
1012 orExtensions :: (ExtsBitmap -> Bool) -> (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap
1013 orExtensions pred1 pred2 bits _ _ _ = pred1 bits || pred2 bits
1014
1015 multiline_doc_comment :: Action
1016 multiline_doc_comment span buf _len = withLexedDocType (worker "")
1017   where
1018     worker commentAcc input docType checkNextLine = case alexGetChar' input of
1019       Just ('\n', input')
1020         | checkNextLine -> case checkIfCommentLine input' of
1021           Just input -> worker ('\n':commentAcc) input docType checkNextLine
1022           Nothing -> docCommentEnd input commentAcc docType buf span
1023         | otherwise -> docCommentEnd input commentAcc docType buf span
1024       Just (c, input) -> worker (c:commentAcc) input docType checkNextLine
1025       Nothing -> docCommentEnd input commentAcc docType buf span
1026
1027     -- Check if the next line of input belongs to this doc comment as well.
1028     -- A doc comment continues onto the next line when the following
1029     -- conditions are met:
1030     --   * The line starts with "--"
1031     --   * The line doesn't start with "---".
1032     --   * The line doesn't start with "-- $", because that would be the
1033     --     start of a /new/ named haddock chunk (#10398).
1034     checkIfCommentLine :: AlexInput -> Maybe AlexInput
1035     checkIfCommentLine input = check (dropNonNewlineSpace input)
1036       where
1037         check input = do
1038           ('-', input) <- alexGetChar' input
1039           ('-', input) <- alexGetChar' input
1040           (c, after_c) <- alexGetChar' input
1041           case c of
1042             '-' -> Nothing
1043             ' ' -> case alexGetChar' after_c of
1044                      Just ('$', _) -> Nothing
1045                      _ -> Just input
1046             _   -> Just input
1047
1048         dropNonNewlineSpace input = case alexGetChar' input of
1049           Just (c, input')
1050             | isSpace c && c /= '\n' -> dropNonNewlineSpace input'
1051             | otherwise -> input
1052           Nothing -> input
1053
1054 lineCommentToken :: Action
1055 lineCommentToken span buf len = do
1056   b <- extension rawTokenStreamEnabled
1057   if b then strtoken ITlineComment span buf len else lexToken
1058
1059 {-
1060   nested comments require traversing by hand, they can't be parsed
1061   using regular expressions.
1062 -}
1063 nested_comment :: P (RealLocated Token) -> Action
1064 nested_comment cont span buf len = do
1065   input <- getInput
1066   go (reverse $ lexemeToString buf len) (1::Int) input
1067   where
1068     go commentAcc 0 input = do
1069       setInput input
1070       b <- extension rawTokenStreamEnabled
1071       if b
1072         then docCommentEnd input commentAcc ITblockComment buf span
1073         else cont
1074     go commentAcc n input = case alexGetChar' input of
1075       Nothing -> errBrace input span
1076       Just ('-',input) -> case alexGetChar' input of
1077         Nothing  -> errBrace input span
1078         Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}'
1079         Just (_,_)          -> go ('-':commentAcc) n input
1080       Just ('\123',input) -> case alexGetChar' input of  -- '{' char
1081         Nothing  -> errBrace input span
1082         Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input
1083         Just (_,_)       -> go ('\123':commentAcc) n input
1084       Just (c,input) -> go (c:commentAcc) n input
1085
1086 nested_doc_comment :: Action
1087 nested_doc_comment span buf _len = withLexedDocType (go "")
1088   where
1089     go commentAcc input docType _ = case alexGetChar' input of
1090       Nothing -> errBrace input span
1091       Just ('-',input) -> case alexGetChar' input of
1092         Nothing -> errBrace input span
1093         Just ('\125',input) ->
1094           docCommentEnd input commentAcc docType buf span
1095         Just (_,_) -> go ('-':commentAcc) input docType False
1096       Just ('\123', input) -> case alexGetChar' input of
1097         Nothing  -> errBrace input span
1098         Just ('-',input) -> do
1099           setInput input
1100           let cont = do input <- getInput; go commentAcc input docType False
1101           nested_comment cont span buf _len
1102         Just (_,_) -> go ('\123':commentAcc) input docType False
1103       Just (c,input) -> go (c:commentAcc) input docType False
1104
1105 withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
1106                  -> P (RealLocated Token)
1107 withLexedDocType lexDocComment = do
1108   input@(AI _ buf) <- getInput
1109   case prevChar buf ' ' of
1110     -- The `Bool` argument to lexDocComment signals whether or not the next
1111     -- line of input might also belong to this doc comment.
1112     '|' -> lexDocComment input ITdocCommentNext True
1113     '^' -> lexDocComment input ITdocCommentPrev True
1114     '$' -> lexDocComment input ITdocCommentNamed True
1115     '*' -> lexDocSection 1 input
1116     _ -> panic "withLexedDocType: Bad doc type"
1117  where
1118     lexDocSection n input = case alexGetChar' input of
1119       Just ('*', input) -> lexDocSection (n+1) input
1120       Just (_,   _)     -> lexDocComment input (ITdocSection n) False
1121       Nothing -> do setInput input; lexToken -- eof reached, lex it normally
1122
1123 -- RULES pragmas turn on the forall and '.' keywords, and we turn them
1124 -- off again at the end of the pragma.
1125 rulePrag :: Action
1126 rulePrag span buf len = do
1127   setExts (.|. xbit InRulePragBit)
1128   let !src = lexemeToString buf len
1129   return (L span (ITrules_prag src))
1130
1131 endPrag :: Action
1132 endPrag span _buf _len = do
1133   setExts (.&. complement (xbit InRulePragBit))
1134   return (L span ITclose_prag)
1135
1136 -- docCommentEnd
1137 -------------------------------------------------------------------------------
1138 -- This function is quite tricky. We can't just return a new token, we also
1139 -- need to update the state of the parser. Why? Because the token is longer
1140 -- than what was lexed by Alex, and the lexToken function doesn't know this, so
1141 -- it writes the wrong token length to the parser state. This function is
1142 -- called afterwards, so it can just update the state.
1143
1144 docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
1145                  RealSrcSpan -> P (RealLocated Token)
1146 docCommentEnd input commentAcc docType buf span = do
1147   setInput input
1148   let (AI loc nextBuf) = input
1149       comment = reverse commentAcc
1150       span' = mkRealSrcSpan (realSrcSpanStart span) loc
1151       last_len = byteDiff buf nextBuf
1152
1153   span `seq` setLastToken span' last_len
1154   return (L span' (docType comment))
1155
1156 errBrace :: AlexInput -> RealSrcSpan -> P a
1157 errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"
1158
1159 open_brace, close_brace :: Action
1160 open_brace span _str _len = do
1161   ctx <- getContext
1162   setContext (NoLayout:ctx)
1163   return (L span ITocurly)
1164 close_brace span _str _len = do
1165   popContext
1166   return (L span ITccurly)
1167
1168 qvarid, qconid :: StringBuffer -> Int -> Token
1169 qvarid buf len = ITqvarid $! splitQualName buf len False
1170 qconid buf len = ITqconid $! splitQualName buf len False
1171
1172 splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString)
1173 -- takes a StringBuffer and a length, and returns the module name
1174 -- and identifier parts of a qualified name.  Splits at the *last* dot,
1175 -- because of hierarchical module names.
1176 splitQualName orig_buf len parens = split orig_buf orig_buf
1177   where
1178     split buf dot_buf
1179         | orig_buf `byteDiff` buf >= len  = done dot_buf
1180         | c == '.'                        = found_dot buf'
1181         | otherwise                       = split buf' dot_buf
1182       where
1183        (c,buf') = nextChar buf
1184
1185     -- careful, we might get names like M....
1186     -- so, if the character after the dot is not upper-case, this is
1187     -- the end of the qualifier part.
1188     found_dot buf -- buf points after the '.'
1189         | isUpper c    = split buf' buf
1190         | otherwise    = done buf
1191       where
1192        (c,buf') = nextChar buf
1193
1194     done dot_buf =
1195         (lexemeToFastString orig_buf (qual_size - 1),
1196          if parens -- Prelude.(+)
1197             then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2)
1198             else lexemeToFastString dot_buf (len - qual_size))
1199       where
1200         qual_size = orig_buf `byteDiff` dot_buf
1201
1202 varid :: Action
1203 varid span buf len =
1204   case lookupUFM reservedWordsFM fs of
1205     Just (ITcase, _) -> do
1206       lambdaCase <- extension lambdaCaseEnabled
1207       keyword <- if lambdaCase
1208                  then do
1209                    lastTk <- getLastTk
1210                    return $ case lastTk of
1211                      Just ITlam -> ITlcase
1212                      _          -> ITcase
1213                  else
1214                    return ITcase
1215       maybe_layout keyword
1216       return $ L span keyword
1217     Just (ITstatic, _) -> do
1218       staticPointers <- extension staticPointersEnabled
1219       if staticPointers
1220         then return $ L span ITstatic
1221         else return $ L span $ ITvarid fs
1222     Just (keyword, 0) -> do
1223       maybe_layout keyword
1224       return $ L span keyword
1225     Just (keyword, exts) -> do
1226       extsEnabled <- extension $ \i -> exts .&. i /= 0
1227       if extsEnabled
1228         then do
1229           maybe_layout keyword
1230           return $ L span keyword
1231         else
1232           return $ L span $ ITvarid fs
1233     Nothing ->
1234       return $ L span $ ITvarid fs
1235   where
1236     !fs = lexemeToFastString buf len
1237
1238 conid :: StringBuffer -> Int -> Token
1239 conid buf len = ITconid $! lexemeToFastString buf len
1240
1241 qvarsym, qconsym :: StringBuffer -> Int -> Token
1242 qvarsym buf len = ITqvarsym $! splitQualName buf len False
1243 qconsym buf len = ITqconsym $! splitQualName buf len False
1244
1245 varsym, consym :: Action
1246 varsym = sym ITvarsym
1247 consym = sym ITconsym
1248
1249 sym :: (FastString -> Token) -> Action
1250 sym con span buf len =
1251   case lookupUFM reservedSymsFM fs of
1252     Just (keyword, exts) -> do
1253       extsEnabled <- extension exts
1254       let !tk | extsEnabled = keyword
1255               | otherwise   = con fs
1256       return $ L span tk
1257     Nothing ->
1258       return $ L span $! con fs
1259   where
1260     !fs = lexemeToFastString buf len
1261
1262 -- Variations on the integral numeric literal.
1263 tok_integral :: (String -> Integer -> Token)
1264              -> (Integer -> Integer)
1265              -> Int -> Int
1266              -> (Integer, (Char -> Int))
1267              -> Action
1268 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len
1269  = return $ L span $ itint (lexemeToString buf len)
1270        $! transint $ parseUnsignedInteger
1271        (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
1272
1273 -- some conveniences for use with tok_integral
1274 tok_num :: (Integer -> Integer)
1275         -> Int -> Int
1276         -> (Integer, (Char->Int)) -> Action
1277 tok_num = tok_integral ITinteger
1278 tok_primint :: (Integer -> Integer)
1279             -> Int -> Int
1280             -> (Integer, (Char->Int)) -> Action
1281 tok_primint = tok_integral ITprimint
1282 tok_primword :: Int -> Int
1283              -> (Integer, (Char->Int)) -> Action
1284 tok_primword = tok_integral ITprimword positive
1285 positive, negative :: (Integer -> Integer)
1286 positive = id
1287 negative = negate
1288 decimal, octal, hexadecimal :: (Integer, Char -> Int)
1289 decimal = (10,octDecDigit)
1290 binary = (2,octDecDigit)
1291 octal = (8,octDecDigit)
1292 hexadecimal = (16,hexDigit)
1293
1294 -- readRational can understand negative rationals, exponents, everything.
1295 tok_float, tok_primfloat, tok_primdouble :: String -> Token
1296 tok_float        str = ITrational   $! readFractionalLit str
1297 tok_primfloat    str = ITprimfloat  $! readFractionalLit str
1298 tok_primdouble   str = ITprimdouble $! readFractionalLit str
1299
1300 readFractionalLit :: String -> FractionalLit
1301 readFractionalLit str = (FL $! str) $! readRational str
1302
1303 -- -----------------------------------------------------------------------------
1304 -- Layout processing
1305
1306 -- we're at the first token on a line, insert layout tokens if necessary
1307 do_bol :: Action
1308 do_bol span _str _len = do
1309         (pos, gen_semic) <- getOffside
1310         case pos of
1311             LT -> do
1312                 --trace "layout: inserting '}'" $ do
1313                 popContext
1314                 -- do NOT pop the lex state, we might have a ';' to insert
1315                 return (L span ITvccurly)
1316             EQ | gen_semic -> do
1317                 --trace "layout: inserting ';'" $ do
1318                 _ <- popLexState
1319                 return (L span ITsemi)
1320             _ -> do
1321                 _ <- popLexState
1322                 lexToken
1323
1324 -- certain keywords put us in the "layout" state, where we might
1325 -- add an opening curly brace.
1326 maybe_layout :: Token -> P ()
1327 maybe_layout t = do -- If the alternative layout rule is enabled then
1328                     -- we never create an implicit layout context here.
1329                     -- Layout is handled XXX instead.
1330                     -- The code for closing implicit contexts, or
1331                     -- inserting implicit semi-colons, is therefore
1332                     -- irrelevant as it only applies in an implicit
1333                     -- context.
1334                     alr <- extension alternativeLayoutRule
1335                     unless alr $ f t
1336     where f ITdo    = pushLexState layout_do
1337           f ITmdo   = pushLexState layout_do
1338           f ITof    = pushLexState layout
1339           f ITlcase = pushLexState layout
1340           f ITlet   = pushLexState layout
1341           f ITwhere = pushLexState layout
1342           f ITrec   = pushLexState layout
1343           f ITif    = pushLexState layout_if
1344           f _       = return ()
1345
1346 -- Pushing a new implicit layout context.  If the indentation of the
1347 -- next token is not greater than the previous layout context, then
1348 -- Haskell 98 says that the new layout context should be empty; that is
1349 -- the lexer must generate {}.
1350 --
1351 -- We are slightly more lenient than this: when the new context is started
1352 -- by a 'do', then we allow the new context to be at the same indentation as
1353 -- the previous context.  This is what the 'strict' argument is for.
1354 new_layout_context :: Bool -> Bool -> Token -> Action
1355 new_layout_context strict gen_semic tok span _buf len = do
1356     _ <- popLexState
1357     (AI l _) <- getInput
1358     let offset = srcLocCol l - len
1359     ctx <- getContext
1360     nondecreasing <- extension nondecreasingIndentation
1361     let strict' = strict || not nondecreasing
1362     case ctx of
1363         Layout prev_off _ : _  |
1364            (strict'     && prev_off >= offset  ||
1365             not strict' && prev_off > offset) -> do
1366                 -- token is indented to the left of the previous context.
1367                 -- we must generate a {} sequence now.
1368                 pushLexState layout_left
1369                 return (L span tok)
1370         _ -> do setContext (Layout offset gen_semic : ctx)
1371                 return (L span tok)
1372
1373 do_layout_left :: Action
1374 do_layout_left span _buf _len = do
1375     _ <- popLexState
1376     pushLexState bol  -- we must be at the start of a line
1377     return (L span ITvccurly)
1378
1379 -- -----------------------------------------------------------------------------
1380 -- LINE pragmas
1381
1382 setLine :: Int -> Action
1383 setLine code span buf len = do
1384   let line = parseUnsignedInteger buf len 10 octDecDigit
1385   setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
1386         -- subtract one: the line number refers to the *following* line
1387   _ <- popLexState
1388   pushLexState code
1389   lexToken
1390
1391 setFile :: Int -> Action
1392 setFile code span buf len = do
1393   let file = mkFastString (go (lexemeToString (stepOn buf) (len-2)))
1394         where go ('\\':c:cs) = c : go cs
1395               go (c:cs)      = c : go cs
1396               go []          = []
1397               -- decode escapes in the filename.  e.g. on Windows
1398               -- when our filenames have backslashes in, gcc seems to
1399               -- escape the backslashes.  One symptom of not doing this
1400               -- is that filenames in error messages look a bit strange:
1401               --   C:\\foo\bar.hs
1402               -- only the first backslash is doubled, because we apply
1403               -- System.FilePath.normalise before printing out
1404               -- filenames and it does not remove duplicate
1405               -- backslashes after the drive letter (should it?).
1406   setAlrLastLoc $ alrInitialLoc file
1407   setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
1408   addSrcFile file
1409   _ <- popLexState
1410   pushLexState code
1411   lexToken
1412
1413 alrInitialLoc :: FastString -> RealSrcSpan
1414 alrInitialLoc file = mkRealSrcSpan loc loc
1415     where -- This is a hack to ensure that the first line in a file
1416           -- looks like it is after the initial location:
1417           loc = mkRealSrcLoc file (-1) (-1)
1418
1419 -- -----------------------------------------------------------------------------
1420 -- Options, includes and language pragmas.
1421
1422 lex_string_prag :: (String -> Token) -> Action
1423 lex_string_prag mkTok span _buf _len
1424     = do input <- getInput
1425          start <- getSrcLoc
1426          tok <- go [] input
1427          end <- getSrcLoc
1428          return (L (mkRealSrcSpan start end) tok)
1429     where go acc input
1430               = if isString input "#-}"
1431                    then do setInput input
1432                            return (mkTok (reverse acc))
1433                    else case alexGetChar input of
1434                           Just (c,i) -> go (c:acc) i
1435                           Nothing -> err input
1436           isString _ [] = True
1437           isString i (x:xs)
1438               = case alexGetChar i of
1439                   Just (c,i') | c == x    -> isString i' xs
1440                   _other -> False
1441           err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma"
1442
1443
1444 -- -----------------------------------------------------------------------------
1445 -- Strings & Chars
1446
1447 -- This stuff is horrible.  I hates it.
1448
1449 lex_string_tok :: Action
1450 lex_string_tok span buf _len = do
1451   tok <- lex_string ""
1452   (AI end bufEnd) <- getInput
1453   let
1454     tok' = case tok of
1455             ITprimstring _ bs -> ITprimstring src bs
1456             ITstring _ s -> ITstring src s
1457             _ -> panic "lex_string_tok"
1458     src = lexemeToString buf (cur bufEnd - cur buf)
1459   return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok')
1460
1461 lex_string :: String -> P Token
1462 lex_string s = do
1463   i <- getInput
1464   case alexGetChar' i of
1465     Nothing -> lit_error i
1466
1467     Just ('"',i)  -> do
1468         setInput i
1469         magicHash <- extension magicHashEnabled
1470         if magicHash
1471           then do
1472             i <- getInput
1473             case alexGetChar' i of
1474               Just ('#',i) -> do
1475                    setInput i
1476                    if any (> '\xFF') s
1477                     then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
1478                     else let bs = unsafeMkByteString (reverse s)
1479                          in return (ITprimstring "" bs)
1480               _other ->
1481                 return (ITstring "" (mkFastString (reverse s)))
1482           else
1483                 return (ITstring "" (mkFastString (reverse s)))
1484
1485     Just ('\\',i)
1486         | Just ('&',i) <- next -> do
1487                 setInput i; lex_string s
1488         | Just (c,i) <- next, c <= '\x7f' && is_space c -> do
1489                            -- is_space only works for <= '\x7f' (#3751, #5425)
1490                 setInput i; lex_stringgap s
1491         where next = alexGetChar' i
1492
1493     Just (c, i1) -> do
1494         case c of
1495           '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s)
1496           c | isAny c -> do setInput i1; lex_string (c:s)
1497           _other -> lit_error i
1498
1499 lex_stringgap :: String -> P Token
1500 lex_stringgap s = do
1501   i <- getInput
1502   c <- getCharOrFail i
1503   case c of
1504     '\\' -> lex_string s
1505     c | c <= '\x7f' && is_space c -> lex_stringgap s
1506                            -- is_space only works for <= '\x7f' (#3751, #5425)
1507     _other -> lit_error i
1508
1509
1510 lex_char_tok :: Action
1511 -- Here we are basically parsing character literals, such as 'x' or '\n'
1512 -- but we additionally spot 'x and ''T, returning ITsimpleQuote and
1513 -- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part
1514 -- (the parser does that).
1515 -- So we have to do two characters of lookahead: when we see 'x we need to
1516 -- see if there's a trailing quote
1517 lex_char_tok span buf _len = do        -- We've seen '
1518    i1 <- getInput       -- Look ahead to first character
1519    let loc = realSrcSpanStart span
1520    case alexGetChar' i1 of
1521         Nothing -> lit_error  i1
1522
1523         Just ('\'', i2@(AI end2 _)) -> do       -- We've seen ''
1524                    setInput i2
1525                    return (L (mkRealSrcSpan loc end2)  ITtyQuote)
1526
1527         Just ('\\', i2@(AI _end2 _)) -> do      -- We've seen 'backslash
1528                   setInput i2
1529                   lit_ch <- lex_escape
1530                   i3 <- getInput
1531                   mc <- getCharOrFail i3 -- Trailing quote
1532                   if mc == '\'' then finish_char_tok buf loc lit_ch
1533                                 else lit_error i3
1534
1535         Just (c, i2@(AI _end2 _))
1536                 | not (isAny c) -> lit_error i1
1537                 | otherwise ->
1538
1539                 -- We've seen 'x, where x is a valid character
1540                 --  (i.e. not newline etc) but not a quote or backslash
1541            case alexGetChar' i2 of      -- Look ahead one more character
1542                 Just ('\'', i3) -> do   -- We've seen 'x'
1543                         setInput i3
1544                         finish_char_tok buf loc c
1545                 _other -> do            -- We've seen 'x not followed by quote
1546                                         -- (including the possibility of EOF)
1547                                         -- Just parse the quote only
1548                         let (AI end _) = i1
1549                         return (L (mkRealSrcSpan loc end) ITsimpleQuote)
1550
1551 finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token)
1552 finish_char_tok buf loc ch  -- We've already seen the closing quote
1553                         -- Just need to check for trailing #
1554   = do  magicHash <- extension magicHashEnabled
1555         i@(AI end bufEnd) <- getInput
1556         let src = lexemeToString buf (cur bufEnd - cur buf)
1557         if magicHash then do
1558                 case alexGetChar' i of
1559                         Just ('#',i@(AI end _)) -> do
1560                           setInput i
1561                           return (L (mkRealSrcSpan loc end) (ITprimchar src ch))
1562                         _other ->
1563                           return (L (mkRealSrcSpan loc end) (ITchar src ch))
1564             else do
1565                    return (L (mkRealSrcSpan loc end) (ITchar src ch))
1566
1567 isAny :: Char -> Bool
1568 isAny c | c > '\x7f' = isPrint c
1569         | otherwise  = is_any c
1570
1571 lex_escape :: P Char
1572 lex_escape = do
1573   i0 <- getInput
1574   c <- getCharOrFail i0
1575   case c of
1576         'a'   -> return '\a'
1577         'b'   -> return '\b'
1578         'f'   -> return '\f'
1579         'n'   -> return '\n'
1580         'r'   -> return '\r'
1581         't'   -> return '\t'
1582         'v'   -> return '\v'
1583         '\\'  -> return '\\'
1584         '"'   -> return '\"'
1585         '\''  -> return '\''
1586         '^'   -> do i1 <- getInput
1587                     c <- getCharOrFail i1
1588                     if c >= '@' && c <= '_'
1589                         then return (chr (ord c - ord '@'))
1590                         else lit_error i1
1591
1592         'x'   -> readNum is_hexdigit 16 hexDigit
1593         'o'   -> readNum is_octdigit  8 octDecDigit
1594         x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)
1595
1596         c1 ->  do
1597            i <- getInput
1598            case alexGetChar' i of
1599             Nothing -> lit_error i0
1600             Just (c2,i2) ->
1601               case alexGetChar' i2 of
1602                 Nothing -> do lit_error i0
1603                 Just (c3,i3) ->
1604                    let str = [c1,c2,c3] in
1605                    case [ (c,rest) | (p,c) <- silly_escape_chars,
1606                                      Just rest <- [stripPrefix p str] ] of
1607                           (escape_char,[]):_ -> do
1608                                 setInput i3
1609                                 return escape_char
1610                           (escape_char,_:_):_ -> do
1611                                 setInput i2
1612                                 return escape_char
1613                           [] -> lit_error i0
1614
1615 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char
1616 readNum is_digit base conv = do
1617   i <- getInput
1618   c <- getCharOrFail i
1619   if is_digit c
1620         then readNum2 is_digit base conv (conv c)
1621         else lit_error i
1622
1623 readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char
1624 readNum2 is_digit base conv i = do
1625   input <- getInput
1626   read i input
1627   where read i input = do
1628           case alexGetChar' input of
1629             Just (c,input') | is_digit c -> do
1630                let i' = i*base + conv c
1631                if i' > 0x10ffff
1632                   then setInput input >> lexError "numeric escape sequence out of range"
1633                   else read i' input'
1634             _other -> do
1635               setInput input; return (chr i)
1636
1637
1638 silly_escape_chars :: [(String, Char)]
1639 silly_escape_chars = [
1640         ("NUL", '\NUL'),
1641         ("SOH", '\SOH'),
1642         ("STX", '\STX'),
1643         ("ETX", '\ETX'),
1644         ("EOT", '\EOT'),
1645         ("ENQ", '\ENQ'),
1646         ("ACK", '\ACK'),
1647         ("BEL", '\BEL'),
1648         ("BS", '\BS'),
1649         ("HT", '\HT'),
1650         ("LF", '\LF'),
1651         ("VT", '\VT'),
1652         ("FF", '\FF'),
1653         ("CR", '\CR'),
1654         ("SO", '\SO'),
1655         ("SI", '\SI'),
1656         ("DLE", '\DLE'),
1657         ("DC1", '\DC1'),
1658         ("DC2", '\DC2'),
1659         ("DC3", '\DC3'),
1660         ("DC4", '\DC4'),
1661         ("NAK", '\NAK'),
1662         ("SYN", '\SYN'),
1663         ("ETB", '\ETB'),
1664         ("CAN", '\CAN'),
1665         ("EM", '\EM'),
1666         ("SUB", '\SUB'),
1667         ("ESC", '\ESC'),
1668         ("FS", '\FS'),
1669         ("GS", '\GS'),
1670         ("RS", '\RS'),
1671         ("US", '\US'),
1672         ("SP", '\SP'),
1673         ("DEL", '\DEL')
1674         ]
1675
1676 -- before calling lit_error, ensure that the current input is pointing to
1677 -- the position of the error in the buffer.  This is so that we can report
1678 -- a correct location to the user, but also so we can detect UTF-8 decoding
1679 -- errors if they occur.
1680 lit_error :: AlexInput -> P a
1681 lit_error i = do setInput i; lexError "lexical error in string/character literal"
1682
1683 getCharOrFail :: AlexInput -> P Char
1684 getCharOrFail i =  do
1685   case alexGetChar' i of
1686         Nothing -> lexError "unexpected end-of-file in string/character literal"
1687         Just (c,i)  -> do setInput i; return c
1688
1689 -- -----------------------------------------------------------------------------
1690 -- QuasiQuote
1691
1692 lex_qquasiquote_tok :: Action
1693 lex_qquasiquote_tok span buf len = do
1694   let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False
1695   quoteStart <- getSrcLoc
1696   quote <- lex_quasiquote quoteStart ""
1697   end <- getSrcLoc
1698   return (L (mkRealSrcSpan (realSrcSpanStart span) end)
1699            (ITqQuasiQuote (qual,
1700                            quoter,
1701                            mkFastString (reverse quote),
1702                            mkRealSrcSpan quoteStart end)))
1703
1704 lex_quasiquote_tok :: Action
1705 lex_quasiquote_tok span buf len = do
1706   let quoter = tail (lexemeToString buf (len - 1))
1707                 -- 'tail' drops the initial '[',
1708                 -- while the -1 drops the trailing '|'
1709   quoteStart <- getSrcLoc
1710   quote <- lex_quasiquote quoteStart ""
1711   end <- getSrcLoc
1712   return (L (mkRealSrcSpan (realSrcSpanStart span) end)
1713            (ITquasiQuote (mkFastString quoter,
1714                           mkFastString (reverse quote),
1715                           mkRealSrcSpan quoteStart end)))
1716
1717 lex_quasiquote :: RealSrcLoc -> String -> P String
1718 lex_quasiquote start s = do
1719   i <- getInput
1720   case alexGetChar' i of
1721     Nothing -> quasiquote_error start
1722
1723     -- NB: The string "|]" terminates the quasiquote,
1724     -- with absolutely no escaping. See the extensive
1725     -- discussion on Trac #5348 for why there is no
1726     -- escape handling.
1727     Just ('|',i)
1728         | Just (']',i) <- alexGetChar' i
1729         -> do { setInput i; return s }
1730
1731     Just (c, i) -> do
1732          setInput i; lex_quasiquote start (c : s)
1733
1734 quasiquote_error :: RealSrcLoc -> P a
1735 quasiquote_error start = do
1736   (AI end buf) <- getInput
1737   reportLexError start end buf "unterminated quasiquotation"
1738
1739 -- -----------------------------------------------------------------------------
1740 -- Warnings
1741
1742 warnTab :: Action
1743 warnTab srcspan _buf _len = do
1744     addTabWarning srcspan
1745     lexToken
1746
1747 warnThen :: WarningFlag -> SDoc -> Action -> Action
1748 warnThen option warning action srcspan buf len = do
1749     addWarning option (RealSrcSpan srcspan) warning
1750     action srcspan buf len
1751
1752 -- -----------------------------------------------------------------------------
1753 -- The Parse Monad
1754
1755 -- | Do we want to generate ';' layout tokens? In some cases we just want to
1756 -- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates
1757 -- alternatives (unlike a `case` expression where we need ';' to as a separator
1758 -- between alternatives).
1759 type GenSemic = Bool
1760
1761 generateSemic, dontGenerateSemic :: GenSemic
1762 generateSemic     = True
1763 dontGenerateSemic = False
1764
1765 data LayoutContext
1766   = NoLayout
1767   | Layout !Int !GenSemic
1768   deriving Show
1769
1770 data ParseResult a
1771   = POk PState a
1772   | PFailed
1773         SrcSpan         -- The start and end of the text span related to
1774                         -- the error.  Might be used in environments which can
1775                         -- show this span, e.g. by highlighting it.
1776         MsgDoc          -- The error message
1777
1778 -- | Test whether a 'WarningFlag' is set
1779 warnopt :: WarningFlag -> ParserFlags -> Bool
1780 warnopt f options = fromEnum f `IntSet.member` pWarningFlags options
1781
1782 -- | Test whether a 'LangExt.Extension' is set
1783 extopt :: LangExt.Extension -> ParserFlags -> Bool
1784 extopt f options = fromEnum f `IntSet.member` pExtensionFlags options
1785
1786 -- | The subset of the 'DynFlags' used by the parser
1787 data ParserFlags = ParserFlags {
1788     pWarningFlags   :: IntSet
1789   , pExtensionFlags :: IntSet
1790   , pThisPackage    :: UnitId      -- ^ key of package currently being compiled
1791   , pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions
1792   }
1793
1794 data PState = PState {
1795         buffer     :: StringBuffer,
1796         options    :: ParserFlags,
1797         -- This needs to take DynFlags as an argument until
1798         -- we have a fix for #10143
1799         messages   :: DynFlags -> Messages,
1800         tab_first  :: Maybe RealSrcSpan, -- pos of first tab warning in the file
1801         tab_count  :: !Int,              -- number of tab warnings in the file
1802         last_tk    :: Maybe Token,
1803         last_loc   :: RealSrcSpan, -- pos of previous token
1804         last_len   :: !Int,        -- len of previous token
1805         loc        :: RealSrcLoc,  -- current loc (end of prev token + 1)
1806         context    :: [LayoutContext],
1807         lex_state  :: [Int],
1808         srcfiles   :: [FastString],
1809         -- Used in the alternative layout rule:
1810         -- These tokens are the next ones to be sent out. They are
1811         -- just blindly emitted, without the rule looking at them again:
1812         alr_pending_implicit_tokens :: [RealLocated Token],
1813         -- This is the next token to be considered or, if it is Nothing,
1814         -- we need to get the next token from the input stream:
1815         alr_next_token :: Maybe (RealLocated Token),
1816         -- This is what we consider to be the location of the last token
1817         -- emitted:
1818         alr_last_loc :: RealSrcSpan,
1819         -- The stack of layout contexts:
1820         alr_context :: [ALRContext],
1821         -- Are we expecting a '{'? If it's Just, then the ALRLayout tells
1822         -- us what sort of layout the '{' will open:
1823         alr_expecting_ocurly :: Maybe ALRLayout,
1824         -- Have we just had the '}' for a let block? If so, than an 'in'
1825         -- token doesn't need to close anything:
1826         alr_justClosedExplicitLetBlock :: Bool,
1827
1828         -- The next three are used to implement Annotations giving the
1829         -- locations of 'noise' tokens in the source, so that users of
1830         -- the GHC API can do source to source conversions.
1831         -- See note [Api annotations] in ApiAnnotation.hs
1832         annotations :: [(ApiAnnKey,[SrcSpan])],
1833         comment_q :: [Located AnnotationComment],
1834         annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
1835      }
1836         -- last_loc and last_len are used when generating error messages,
1837         -- and in pushCurrentContext only.  Sigh, if only Happy passed the
1838         -- current token to happyError, we could at least get rid of last_len.
1839         -- Getting rid of last_loc would require finding another way to
1840         -- implement pushCurrentContext (which is only called from one place).
1841
1842 data ALRContext = ALRNoLayout Bool{- does it contain commas? -}
1843                               Bool{- is it a 'let' block? -}
1844                 | ALRLayout ALRLayout Int
1845 data ALRLayout = ALRLayoutLet
1846                | ALRLayoutWhere
1847                | ALRLayoutOf
1848                | ALRLayoutDo
1849
1850 newtype P a = P { unP :: PState -> ParseResult a }
1851
1852 instance Functor P where
1853   fmap = liftM
1854
1855 instance Applicative P where
1856   pure = returnP
1857   (<*>) = ap
1858
1859 instance Monad P where
1860   (>>=) = thenP
1861   fail = failP
1862
1863 #if __GLASGOW_HASKELL__ > 710
1864 instance MonadFail P where
1865   fail = failP
1866 #endif
1867
1868 returnP :: a -> P a
1869 returnP a = a `seq` (P $ \s -> POk s a)
1870
1871 thenP :: P a -> (a -> P b) -> P b
1872 (P m) `thenP` k = P $ \ s ->
1873         case m s of
1874                 POk s1 a         -> (unP (k a)) s1
1875                 PFailed span err -> PFailed span err
1876
1877 failP :: String -> P a
1878 failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
1879
1880 failMsgP :: String -> P a
1881 failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
1882
1883 failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
1884 failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
1885
1886 failSpanMsgP :: SrcSpan -> SDoc -> P a
1887 failSpanMsgP span msg = P $ \_ -> PFailed span msg
1888
1889 getPState :: P PState
1890 getPState = P $ \s -> POk s s
1891
1892 withThisPackage :: (UnitId -> a) -> P a
1893 withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o))
1894
1895 extension :: (ExtsBitmap -> Bool) -> P Bool
1896 extension p = P $ \s -> POk s (p $! (pExtsBitmap . options) s)
1897
1898 getExts :: P ExtsBitmap
1899 getExts = P $ \s -> POk s (pExtsBitmap . options $ s)
1900
1901 setExts :: (ExtsBitmap -> ExtsBitmap) -> P ()
1902 setExts f = P $ \s -> POk s {
1903   options =
1904     let p = options s
1905     in  p { pExtsBitmap = f (pExtsBitmap p) }
1906   } ()
1907
1908 setSrcLoc :: RealSrcLoc -> P ()
1909 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
1910
1911 getSrcLoc :: P RealSrcLoc
1912 getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
1913
1914 addSrcFile :: FastString -> P ()
1915 addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
1916
1917 setLastToken :: RealSrcSpan -> Int -> P ()
1918 setLastToken loc len = P $ \s -> POk s {
1919   last_loc=loc,
1920   last_len=len
1921   } ()
1922
1923 setLastTk :: Token -> P ()
1924 setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()
1925
1926 getLastTk :: P (Maybe Token)
1927 getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
1928
1929 data AlexInput = AI RealSrcLoc StringBuffer
1930
1931 alexInputPrevChar :: AlexInput -> Char
1932 alexInputPrevChar (AI _ buf) = prevChar buf '\n'
1933
1934 -- backwards compatibility for Alex 2.x
1935 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
1936 alexGetChar inp = case alexGetByte inp of
1937                     Nothing    -> Nothing
1938                     Just (b,i) -> c `seq` Just (c,i)
1939                        where c = chr $ fromIntegral b
1940
1941 alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
1942 alexGetByte (AI loc s)
1943   | atEnd s   = Nothing
1944   | otherwise = byte `seq` loc' `seq` s' `seq`
1945                 --trace (show (ord c)) $
1946                 Just (byte, (AI loc' s'))
1947   where (c,s') = nextChar s
1948         loc'   = advanceSrcLoc loc c
1949         byte   = fromIntegral $ ord adj_c
1950
1951         non_graphic     = '\x00'
1952         upper           = '\x01'
1953         lower           = '\x02'
1954         digit           = '\x03'
1955         symbol          = '\x04'
1956         space           = '\x05'
1957         other_graphic   = '\x06'
1958         uniidchar       = '\x07'
1959
1960         adj_c
1961           | c <= '\x07' = non_graphic
1962           | c <= '\x7f' = c
1963           -- Alex doesn't handle Unicode, so when Unicode
1964           -- character is encountered we output these values
1965           -- with the actual character value hidden in the state.
1966           | otherwise =
1967                 -- NB: The logic behind these definitions is also reflected
1968                 -- in basicTypes/Lexeme.hs
1969                 -- Any changes here should likely be reflected there.
1970
1971                 case generalCategory c of
1972                   UppercaseLetter       -> upper
1973                   LowercaseLetter       -> lower
1974                   TitlecaseLetter       -> upper
1975                   ModifierLetter        -> uniidchar -- see #10196
1976                   OtherLetter           -> lower -- see #1103
1977                   NonSpacingMark        -> uniidchar -- see #7650
1978                   SpacingCombiningMark  -> other_graphic
1979                   EnclosingMark         -> other_graphic
1980                   DecimalNumber         -> digit
1981                   LetterNumber          -> other_graphic
1982                   OtherNumber           -> digit -- see #4373
1983                   ConnectorPunctuation  -> symbol
1984                   DashPunctuation       -> symbol
1985                   OpenPunctuation       -> other_graphic
1986                   ClosePunctuation      -> other_graphic
1987                   InitialQuote          -> other_graphic
1988                   FinalQuote            -> other_graphic
1989                   OtherPunctuation      -> symbol
1990                   MathSymbol            -> symbol
1991                   CurrencySymbol        -> symbol
1992                   ModifierSymbol        -> symbol
1993                   OtherSymbol           -> symbol
1994                   Space                 -> space
1995                   _other                -> non_graphic
1996
1997 -- This version does not squash unicode characters, it is used when
1998 -- lexing strings.
1999 alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
2000 alexGetChar' (AI loc s)
2001   | atEnd s   = Nothing
2002   | otherwise = c `seq` loc' `seq` s' `seq`
2003                 --trace (show (ord c)) $
2004                 Just (c, (AI loc' s'))
2005   where (c,s') = nextChar s
2006         loc'   = advanceSrcLoc loc c
2007
2008 getInput :: P AlexInput
2009 getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)
2010
2011 setInput :: AlexInput -> P ()
2012 setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()
2013
2014 nextIsEOF :: P Bool
2015 nextIsEOF = do
2016   AI _ s <- getInput
2017   return $ atEnd s
2018
2019 pushLexState :: Int -> P ()
2020 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
2021
2022 popLexState :: P Int
2023 popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
2024
2025 getLexState :: P Int
2026 getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
2027
2028 popNextToken :: P (Maybe (RealLocated Token))
2029 popNextToken
2030     = P $ \s@PState{ alr_next_token = m } ->
2031               POk (s {alr_next_token = Nothing}) m
2032
2033 activeContext :: P Bool
2034 activeContext = do
2035   ctxt <- getALRContext
2036   expc <- getAlrExpectingOCurly
2037   impt <- implicitTokenPending
2038   case (ctxt,expc) of
2039     ([],Nothing) -> return impt
2040     _other       -> return True
2041
2042 setAlrLastLoc :: RealSrcSpan -> P ()
2043 setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
2044
2045 getAlrLastLoc :: P RealSrcSpan
2046 getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
2047
2048 getALRContext :: P [ALRContext]
2049 getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs
2050
2051 setALRContext :: [ALRContext] -> P ()
2052 setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()
2053
2054 getALRTransitional :: P Bool
2055 getALRTransitional = P $ \s@PState {options = o} ->
2056   POk s (extopt LangExt.AlternativeLayoutRuleTransitional o)
2057
2058 getJustClosedExplicitLetBlock :: P Bool
2059 getJustClosedExplicitLetBlock
2060  = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b
2061
2062 setJustClosedExplicitLetBlock :: Bool -> P ()
2063 setJustClosedExplicitLetBlock b
2064  = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
2065
2066 setNextToken :: RealLocated Token -> P ()
2067 setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
2068
2069 implicitTokenPending :: P Bool
2070 implicitTokenPending
2071     = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
2072               case ts of
2073               [] -> POk s False
2074               _  -> POk s True
2075
2076 popPendingImplicitToken :: P (Maybe (RealLocated Token))
2077 popPendingImplicitToken
2078     = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
2079               case ts of
2080               [] -> POk s Nothing
2081               (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
2082
2083 setPendingImplicitTokens :: [RealLocated Token] -> P ()
2084 setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
2085
2086 getAlrExpectingOCurly :: P (Maybe ALRLayout)
2087 getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b
2088
2089 setAlrExpectingOCurly :: Maybe ALRLayout -> P ()
2090 setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
2091
2092 -- for reasons of efficiency, flags indicating language extensions (eg,
2093 -- -fglasgow-exts or -XParallelArrays) are represented by a bitmap
2094 -- stored in an unboxed Word64
2095 type ExtsBitmap = Word64
2096
2097 xbit :: ExtBits -> ExtsBitmap
2098 xbit = bit . fromEnum
2099
2100 xtest :: ExtBits -> ExtsBitmap -> Bool
2101 xtest ext xmap = testBit xmap (fromEnum ext)
2102
2103 data ExtBits
2104   = FfiBit
2105   | InterruptibleFfiBit
2106   | CApiFfiBit
2107   | ParrBit
2108   | ArrowsBit
2109   | ThBit
2110   | ThQuotesBit
2111   | IpBit
2112   | OverloadedLabelsBit -- #x overloaded labels
2113   | ExplicitForallBit -- the 'forall' keyword and '.' symbol
2114   | BangPatBit -- Tells the parser to understand bang-patterns
2115                -- (doesn't affect the lexer)
2116   | PatternSynonymsBit -- pattern synonyms
2117   | HaddockBit-- Lex and parse Haddock comments
2118   | MagicHashBit -- "#" in both functions and operators
2119   | RecursiveDoBit -- mdo
2120   | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc
2121   | UnboxedTuplesBit -- (# and #)
2122   | UnboxedSumsBit -- (# and #)
2123   | DatatypeContextsBit
2124   | TransformComprehensionsBit
2125   | QqBit -- enable quasiquoting
2126   | InRulePragBit
2127   | RawTokenStreamBit -- producing a token stream with all comments included
2128   | SccProfilingOnBit
2129   | HpcBit
2130   | AlternativeLayoutRuleBit
2131   | RelaxedLayoutBit
2132   | NondecreasingIndentationBit
2133   | SafeHaskellBit
2134   | TraditionalRecordSyntaxBit
2135   | ExplicitNamespacesBit
2136   | LambdaCaseBit
2137   | BinaryLiteralsBit
2138   | NegativeLiteralsBit
2139   | TypeApplicationsBit
2140   | StaticPointersBit
2141   deriving Enum
2142
2143
2144 always :: ExtsBitmap -> Bool
2145 always           _     = True
2146 parrEnabled :: ExtsBitmap -> Bool
2147 parrEnabled = xtest ParrBit
2148 arrowsEnabled :: ExtsBitmap -> Bool
2149 arrowsEnabled = xtest ArrowsBit
2150 thEnabled :: ExtsBitmap -> Bool
2151 thEnabled = xtest ThBit
2152 thQuotesEnabled :: ExtsBitmap -> Bool
2153 thQuotesEnabled = xtest ThQuotesBit
2154 ipEnabled :: ExtsBitmap -> Bool
2155 ipEnabled = xtest IpBit
2156 overloadedLabelsEnabled :: ExtsBitmap -> Bool
2157 overloadedLabelsEnabled = xtest OverloadedLabelsBit
2158 explicitForallEnabled :: ExtsBitmap -> Bool
2159 explicitForallEnabled = xtest ExplicitForallBit
2160 bangPatEnabled :: ExtsBitmap -> Bool
2161 bangPatEnabled = xtest BangPatBit
2162 haddockEnabled :: ExtsBitmap -> Bool
2163 haddockEnabled = xtest HaddockBit
2164 magicHashEnabled :: ExtsBitmap -> Bool
2165 magicHashEnabled = xtest MagicHashBit
2166 unicodeSyntaxEnabled :: ExtsBitmap -> Bool
2167 unicodeSyntaxEnabled = xtest UnicodeSyntaxBit
2168 unboxedTuplesEnabled :: ExtsBitmap -> Bool
2169 unboxedTuplesEnabled = xtest UnboxedTuplesBit
2170 unboxedSumsEnabled :: ExtsBitmap -> Bool
2171 unboxedSumsEnabled = xtest UnboxedSumsBit
2172 datatypeContextsEnabled :: ExtsBitmap -> Bool
2173 datatypeContextsEnabled = xtest DatatypeContextsBit
2174 qqEnabled :: ExtsBitmap -> Bool
2175 qqEnabled = xtest QqBit
2176 inRulePrag :: ExtsBitmap -> Bool
2177 inRulePrag = xtest InRulePragBit
2178 rawTokenStreamEnabled :: ExtsBitmap -> Bool
2179 rawTokenStreamEnabled = xtest RawTokenStreamBit
2180 alternativeLayoutRule :: ExtsBitmap -> Bool
2181 alternativeLayoutRule = xtest AlternativeLayoutRuleBit
2182 hpcEnabled :: ExtsBitmap -> Bool
2183 hpcEnabled = xtest HpcBit
2184 relaxedLayout :: ExtsBitmap -> Bool
2185 relaxedLayout = xtest RelaxedLayoutBit
2186 nondecreasingIndentation :: ExtsBitmap -> Bool
2187 nondecreasingIndentation = xtest NondecreasingIndentationBit
2188 sccProfilingOn :: ExtsBitmap -> Bool
2189 sccProfilingOn = xtest SccProfilingOnBit
2190 traditionalRecordSyntaxEnabled :: ExtsBitmap -> Bool
2191 traditionalRecordSyntaxEnabled = xtest TraditionalRecordSyntaxBit
2192
2193 explicitNamespacesEnabled :: ExtsBitmap -> Bool
2194 explicitNamespacesEnabled = xtest ExplicitNamespacesBit
2195 lambdaCaseEnabled :: ExtsBitmap -> Bool
2196 lambdaCaseEnabled = xtest LambdaCaseBit
2197 binaryLiteralsEnabled :: ExtsBitmap -> Bool
2198 binaryLiteralsEnabled = xtest BinaryLiteralsBit
2199 negativeLiteralsEnabled :: ExtsBitmap -> Bool
2200 negativeLiteralsEnabled = xtest NegativeLiteralsBit
2201 patternSynonymsEnabled :: ExtsBitmap -> Bool
2202 patternSynonymsEnabled = xtest PatternSynonymsBit
2203 typeApplicationEnabled :: ExtsBitmap -> Bool
2204 typeApplicationEnabled = xtest TypeApplicationsBit
2205 staticPointersEnabled :: ExtsBitmap -> Bool
2206 staticPointersEnabled = xtest StaticPointersBit
2207
2208 -- PState for parsing options pragmas
2209 --
2210 pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
2211 pragState dynflags buf loc = (mkPState dynflags buf loc) {
2212                                  lex_state = [bol, option_prags, 0]
2213                              }
2214
2215 -- | Extracts the flag information needed for parsing
2216 mkParserFlags :: DynFlags -> ParserFlags
2217 mkParserFlags flags =
2218     ParserFlags {
2219       pWarningFlags = DynFlags.warningFlags flags
2220     , pExtensionFlags = DynFlags.extensionFlags flags
2221     , pThisPackage = DynFlags.thisPackage flags
2222     , pExtsBitmap = bitmap
2223     }
2224   where
2225       bitmap =     FfiBit                      `setBitIf` xopt LangExt.ForeignFunctionInterface flags
2226                .|. InterruptibleFfiBit         `setBitIf` xopt LangExt.InterruptibleFFI         flags
2227                .|. CApiFfiBit                  `setBitIf` xopt LangExt.CApiFFI                  flags
2228                .|. ParrBit                     `setBitIf` xopt LangExt.ParallelArrays           flags
2229                .|. ArrowsBit                   `setBitIf` xopt LangExt.Arrows                   flags
2230                .|. ThBit                       `setBitIf` xopt LangExt.TemplateHaskell          flags
2231                .|. ThQuotesBit                 `setBitIf` xopt LangExt.TemplateHaskellQuotes    flags
2232                .|. QqBit                       `setBitIf` xopt LangExt.QuasiQuotes              flags
2233                .|. IpBit                       `setBitIf` xopt LangExt.ImplicitParams           flags
2234                .|. OverloadedLabelsBit         `setBitIf` xopt LangExt.OverloadedLabels         flags
2235                .|. ExplicitForallBit           `setBitIf` xopt LangExt.ExplicitForAll           flags
2236                .|. BangPatBit                  `setBitIf` xopt LangExt.BangPatterns             flags
2237                .|. HaddockBit                  `setBitIf` gopt Opt_Haddock                      flags
2238                .|. MagicHashBit                `setBitIf` xopt LangExt.MagicHash                flags
2239                .|. RecursiveDoBit              `setBitIf` xopt LangExt.RecursiveDo              flags
2240                .|. UnicodeSyntaxBit            `setBitIf` xopt LangExt.UnicodeSyntax            flags
2241                .|. UnboxedTuplesBit            `setBitIf` xopt LangExt.UnboxedTuples            flags
2242                .|. UnboxedSumsBit              `setBitIf` xopt LangExt.UnboxedSums              flags
2243                .|. DatatypeContextsBit         `setBitIf` xopt LangExt.DatatypeContexts         flags
2244                .|. TransformComprehensionsBit  `setBitIf` xopt LangExt.TransformListComp        flags
2245                .|. TransformComprehensionsBit  `setBitIf` xopt LangExt.MonadComprehensions      flags
2246                .|. RawTokenStreamBit           `setBitIf` gopt Opt_KeepRawTokenStream           flags
2247                .|. HpcBit                      `setBitIf` gopt Opt_Hpc                          flags
2248                .|. AlternativeLayoutRuleBit    `setBitIf` xopt LangExt.AlternativeLayoutRule    flags
2249                .|. RelaxedLayoutBit            `setBitIf` xopt LangExt.RelaxedLayout            flags
2250                .|. SccProfilingOnBit           `setBitIf` gopt Opt_SccProfilingOn               flags
2251                .|. NondecreasingIndentationBit `setBitIf` xopt LangExt.NondecreasingIndentation flags
2252                .|. SafeHaskellBit              `setBitIf` safeImportsOn                         flags
2253                .|. TraditionalRecordSyntaxBit  `setBitIf` xopt LangExt.TraditionalRecordSyntax  flags
2254                .|. ExplicitNamespacesBit       `setBitIf` xopt LangExt.ExplicitNamespaces flags
2255                .|. LambdaCaseBit               `setBitIf` xopt LangExt.LambdaCase               flags
2256                .|. BinaryLiteralsBit           `setBitIf` xopt LangExt.BinaryLiterals           flags
2257                .|. NegativeLiteralsBit         `setBitIf` xopt LangExt.NegativeLiterals         flags
2258                .|. PatternSynonymsBit          `setBitIf` xopt LangExt.PatternSynonyms          flags
2259                .|. TypeApplicationsBit         `setBitIf` xopt LangExt.TypeApplications         flags
2260                .|. StaticPointersBit           `setBitIf` xopt LangExt.StaticPointers           flags
2261
2262       setBitIf :: ExtBits -> Bool -> ExtsBitmap
2263       b `setBitIf` cond | cond      = xbit b
2264                         | otherwise = 0
2265
2266 -- | Creates a parse state from a 'DynFlags' value
2267 mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
2268 mkPState flags = mkPStatePure (mkParserFlags flags)
2269
2270 -- | Creates a parse state from a 'ParserFlags' value
2271 mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState
2272 mkPStatePure options buf loc =
2273   PState {
2274       buffer        = buf,
2275       options       = options,
2276       messages      = const emptyMessages,
2277       tab_first     = Nothing,
2278       tab_count     = 0,
2279       last_tk       = Nothing,
2280       last_loc      = mkRealSrcSpan loc loc,
2281       last_len      = 0,
2282       loc           = loc,
2283       context       = [],
2284       lex_state     = [bol, 0],
2285       srcfiles      = [],
2286       alr_pending_implicit_tokens = [],
2287       alr_next_token = Nothing,
2288       alr_last_loc = alrInitialLoc (fsLit "<no file>"),
2289       alr_context = [],
2290       alr_expecting_ocurly = Nothing,
2291       alr_justClosedExplicitLetBlock = False,
2292       annotations = [],
2293       comment_q = [],
2294       annotations_comments = []
2295     }
2296
2297 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
2298 addWarning option srcspan warning
2299  = P $ \s@PState{messages=m, options=o} ->
2300        let
2301            m' d =
2302                let (ws, es) = m d
2303                    warning' = makeIntoWarning (Reason option) $
2304                       mkWarnMsg d srcspan alwaysQualify warning
2305                    ws' = if warnopt option o then ws `snocBag` warning' else ws
2306                in (ws', es)
2307        in POk s{messages=m'} ()
2308
2309 addTabWarning :: RealSrcSpan -> P ()
2310 addTabWarning srcspan
2311  = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->
2312        let tf' = if isJust tf then tf else Just srcspan
2313            tc' = tc + 1
2314            s' = if warnopt Opt_WarnTabs o
2315                 then s{tab_first = tf', tab_count = tc'}
2316                 else s
2317        in POk s' ()
2318
2319 mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg
2320 mkTabWarning PState{tab_first=tf, tab_count=tc} d =
2321   let middle = if tc == 1
2322         then text ""
2323         else text ", and in" <+> speakNOf (tc - 1) (text "further location")
2324       message = text "Tab character found here"
2325                 <> middle
2326                 <> text "."
2327                 $+$ text "Please use spaces instead."
2328   in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $
2329                  mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf
2330
2331 getMessages :: PState -> DynFlags -> Messages
2332 getMessages p@PState{messages=m} d =
2333   let (ws, es) = m d
2334       tabwarning = mkTabWarning p d
2335       ws' = maybe ws (`consBag` ws) tabwarning
2336   in (ws', es)
2337
2338 getContext :: P [LayoutContext]
2339 getContext = P $ \s@PState{context=ctx} -> POk s ctx
2340
2341 setContext :: [LayoutContext] -> P ()
2342 setContext ctx = P $ \s -> POk s{context=ctx} ()
2343
2344 popContext :: P ()
2345 popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
2346                               last_len = len, last_loc = last_loc }) ->
2347   case ctx of
2348         (_:tl) -> POk s{ context = tl } ()
2349         []     -> PFailed (RealSrcSpan last_loc) (srcParseErr o buf len)
2350
2351 -- Push a new layout context at the indentation of the last token read.
2352 pushCurrentContext :: GenSemic -> P ()
2353 pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } ->
2354     POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} ()
2355
2356 -- This is only used at the outer level of a module when the 'module' keyword is
2357 -- missing.
2358 pushModuleContext :: P ()
2359 pushModuleContext = pushCurrentContext generateSemic
2360
2361 getOffside :: P (Ordering, Bool)
2362 getOffside = P $ \s@PState{last_loc=loc, context=stk} ->
2363                 let offs = srcSpanStartCol loc in
2364                 let ord = case stk of
2365                             Layout n gen_semic : _ ->
2366                               --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $
2367                               (compare offs n, gen_semic)
2368                             _ ->
2369                               (GT, dontGenerateSemic)
2370                 in POk s ord
2371
2372 -- ---------------------------------------------------------------------------
2373 -- Construct a parse error
2374
2375 srcParseErr
2376   :: ParserFlags
2377   -> StringBuffer       -- current buffer (placed just after the last token)
2378   -> Int                -- length of the previous token
2379   -> MsgDoc
2380 srcParseErr options buf len
2381   = if null token
2382          then text "parse error (possibly incorrect indentation or mismatched brackets)"
2383          else text "parse error on input" <+> quotes (text token)
2384               $$ ppWhen (not th_enabled && token == "$") -- #7396
2385                         (text "Perhaps you intended to use TemplateHaskell")
2386               $$ ppWhen (token == "<-")
2387                         (text "Perhaps this statement should be within a 'do' block?")
2388               $$ ppWhen (token == "=")
2389                         (text "Perhaps you need a 'let' in a 'do' block?"
2390                          $$ text "e.g. 'let x = 5' instead of 'x = 5'")
2391   where token = lexemeToString (offsetBytes (-len) buf) len
2392         th_enabled = extopt LangExt.TemplateHaskell options
2393
2394 -- Report a parse failure, giving the span of the previous token as
2395 -- the location of the error.  This is the entry point for errors
2396 -- detected during parsing.
2397 srcParseFail :: P a
2398 srcParseFail = P $ \PState{ buffer = buf, options = o, last_len = len,
2399                             last_loc = last_loc } ->
2400     PFailed (RealSrcSpan last_loc) (srcParseErr o buf len)
2401
2402 -- A lexical error is reported at a particular position in the source file,
2403 -- not over a token range.
2404 lexError :: String -> P a
2405 lexError str = do
2406   loc <- getSrcLoc
2407   (AI end buf) <- getInput
2408   reportLexError loc end buf str
2409
2410 -- -----------------------------------------------------------------------------
2411 -- This is the top-level function: called from the parser each time a
2412 -- new token is to be read from the input.
2413
2414 lexer :: Bool -> (Located Token -> P a) -> P a
2415 lexer queueComments cont = do
2416   alr <- extension alternativeLayoutRule
2417   let lexTokenFun = if alr then lexTokenAlr else lexToken
2418   (L span tok) <- lexTokenFun
2419   --trace ("token: " ++ show tok) $ do
2420
2421   case tok of
2422     ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span)
2423     _ -> return ()
2424
2425   if (queueComments && isDocComment tok)
2426     then queueComment (L (RealSrcSpan span) tok)
2427     else return ()
2428
2429   if (queueComments && isComment tok)
2430     then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont
2431     else cont (L (RealSrcSpan span) tok)
2432
2433 lexTokenAlr :: P (RealLocated Token)
2434 lexTokenAlr = do mPending <- popPendingImplicitToken
2435                  t <- case mPending of
2436                       Nothing ->
2437                           do mNext <- popNextToken
2438                              t <- case mNext of
2439                                   Nothing -> lexToken
2440                                   Just next -> return next
2441                              alternativeLayoutRuleToken t
2442                       Just t ->
2443                           return t
2444                  setAlrLastLoc (getLoc t)
2445                  case unLoc t of
2446                      ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
2447                      ITlet   -> setAlrExpectingOCurly (Just ALRLayoutLet)
2448                      ITof    -> setAlrExpectingOCurly (Just ALRLayoutOf)
2449                      ITdo    -> setAlrExpectingOCurly (Just ALRLayoutDo)
2450                      ITmdo   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2451                      ITrec   -> setAlrExpectingOCurly (Just ALRLayoutDo)
2452                      _       -> return ()
2453                  return t
2454
2455 alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)
2456 alternativeLayoutRuleToken t
2457     = do context <- getALRContext
2458          lastLoc <- getAlrLastLoc
2459          mExpectingOCurly <- getAlrExpectingOCurly
2460          transitional <- getALRTransitional
2461          justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
2462          setJustClosedExplicitLetBlock False
2463          let thisLoc = getLoc t
2464              thisCol = srcSpanStartCol thisLoc
2465              newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
2466          case (unLoc t, context, mExpectingOCurly) of
2467              -- This case handles a GHC extension to the original H98
2468              -- layout rule...
2469              (ITocurly, _, Just alrLayout) ->
2470                  do setAlrExpectingOCurly Nothing
2471                     let isLet = case alrLayout of
2472                                 ALRLayoutLet -> True
2473                                 _ -> False
2474                     setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)
2475                     return t
2476              -- ...and makes this case unnecessary
2477              {-
2478              -- I think our implicit open-curly handling is slightly
2479              -- different to John's, in how it interacts with newlines
2480              -- and "in"
2481              (ITocurly, _, Just _) ->
2482                  do setAlrExpectingOCurly Nothing
2483                     setNextToken t
2484                     lexTokenAlr
2485              -}
2486              (_, ALRLayout _ col : _ls, Just expectingOCurly)
2487               | (thisCol > col) ||
2488                 (thisCol == col &&
2489                  isNonDecreasingIntentation expectingOCurly) ->
2490                  do setAlrExpectingOCurly Nothing
2491                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2492                     setNextToken t
2493                     return (L thisLoc ITocurly)
2494               | otherwise ->
2495                  do setAlrExpectingOCurly Nothing
2496                     setPendingImplicitTokens [L lastLoc ITccurly]
2497                     setNextToken t
2498                     return (L lastLoc ITocurly)
2499              (_, _, Just expectingOCurly) ->
2500                  do setAlrExpectingOCurly Nothing
2501                     setALRContext (ALRLayout expectingOCurly thisCol : context)
2502                     setNextToken t
2503                     return (L thisLoc ITocurly)
2504              -- We do the [] cases earlier than in the spec, as we
2505              -- have an actual EOF token
2506              (ITeof, ALRLayout _ _ : ls, _) ->
2507                  do setALRContext ls
2508                     setNextToken t
2509                     return (L thisLoc ITccurly)
2510              (ITeof, _, _) ->
2511                  return t
2512              -- the other ITeof case omitted; general case below covers it
2513              (ITin, _, _)
2514               | justClosedExplicitLetBlock ->
2515                  return t
2516              (ITin, ALRLayout ALRLayoutLet _ : ls, _)
2517               | newLine ->
2518                  do setPendingImplicitTokens [t]
2519                     setALRContext ls
2520                     return (L thisLoc ITccurly)
2521              -- This next case is to handle a transitional issue:
2522              (ITwhere, ALRLayout _ col : ls, _)
2523               | newLine && thisCol == col && transitional ->
2524                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2525                                (RealSrcSpan thisLoc)
2526                                (transitionalAlternativeLayoutWarning
2527                                     "`where' clause at the same depth as implicit layout block")
2528                     setALRContext ls
2529                     setNextToken t
2530                     -- Note that we use lastLoc, as we may need to close
2531                     -- more layouts, or give a semicolon
2532                     return (L lastLoc ITccurly)
2533              -- This next case is to handle a transitional issue:
2534              (ITvbar, ALRLayout _ col : ls, _)
2535               | newLine && thisCol == col && transitional ->
2536                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
2537                                (RealSrcSpan thisLoc)
2538                                (transitionalAlternativeLayoutWarning
2539                                     "`|' at the same depth as implicit layout block")
2540                     setALRContext ls
2541                     setNextToken t
2542                     -- Note that we use lastLoc, as we may need to close
2543                     -- more layouts, or give a semicolon
2544                     return (L lastLoc ITccurly)
2545              (_, ALRLayout _ col : ls, _)
2546               | newLine && thisCol == col ->
2547                  do setNextToken t
2548                     return (L thisLoc ITsemi)
2549               | newLine && thisCol < col ->
2550                  do setALRContext ls
2551                     setNextToken t
2552                     -- Note that we use lastLoc, as we may need to close
2553                     -- more layouts, or give a semicolon
2554                     return (L lastLoc ITccurly)
2555              -- We need to handle close before open, as 'then' is both
2556              -- an open and a close
2557              (u, _, _)
2558               | isALRclose u ->
2559                  case context of
2560                  ALRLayout _ _ : ls ->
2561                      do setALRContext ls
2562                         setNextToken t
2563                         return (L thisLoc ITccurly)
2564                  ALRNoLayout _ isLet : ls ->
2565                      do let ls' = if isALRopen u
2566                                      then ALRNoLayout (containsCommas u) False : ls
2567                                      else ls
2568                         setALRContext ls'
2569                         when isLet $ setJustClosedExplicitLetBlock True
2570                         return t
2571                  [] ->
2572                      do let ls = if isALRopen u
2573                                     then [ALRNoLayout (containsCommas u) False]
2574                                     else []
2575                         setALRContext ls
2576                         -- XXX This is an error in John's code, but
2577                         -- it looks reachable to me at first glance
2578                         return t
2579              (u, _, _)
2580               | isALRopen u ->
2581                  do setALRContext (ALRNoLayout (containsCommas u) False : context)
2582                     return t
2583              (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->
2584                  do setALRContext ls
2585                     setPendingImplicitTokens [t]
2586                     return (L thisLoc ITccurly)
2587              (ITin, ALRLayout _ _ : ls, _) ->
2588                  do setALRContext ls
2589                     setNextToken t
2590                     return (L thisLoc ITccurly)
2591              -- the other ITin case omitted; general case below covers it
2592              (ITcomma, ALRLayout _ _ : ls, _)
2593               | topNoLayoutContainsCommas ls ->
2594                  do setALRContext ls
2595                     setNextToken t
2596                     return (L thisLoc ITccurly)
2597              (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->
2598                  do setALRContext ls
2599                     setPendingImplicitTokens [t]
2600                     return (L thisLoc ITccurly)
2601              -- the other ITwhere case omitted; general case below covers it
2602              (_, _, _) -> return t
2603
2604 transitionalAlternativeLayoutWarning :: String -> SDoc
2605 transitionalAlternativeLayoutWarning msg
2606     = text "transitional layout will not be accepted in the future:"
2607    $$ text msg
2608
2609 isALRopen :: Token -> Bool
2610 isALRopen ITcase          = True
2611 isALRopen ITif            = True
2612 isALRopen ITthen          = True
2613 isALRopen IToparen        = True
2614 isALRopen ITobrack        = True
2615 isALRopen ITocurly        = True
2616 -- GHC Extensions:
2617 isALRopen IToubxparen     = True
2618 isALRopen ITparenEscape   = True
2619 isALRopen ITparenTyEscape = True
2620 isALRopen _               = False
2621
2622 isALRclose :: Token -> Bool
2623 isALRclose ITof     = True
2624 isALRclose ITthen   = True
2625 isALRclose ITelse   = True
2626 isALRclose ITcparen = True
2627 isALRclose ITcbrack = True
2628 isALRclose ITccurly = True
2629 -- GHC Extensions:
2630 isALRclose ITcubxparen = True
2631 isALRclose _        = False
2632
2633 isNonDecreasingIntentation :: ALRLayout -> Bool
2634 isNonDecreasingIntentation ALRLayoutDo = True
2635 isNonDecreasingIntentation _           = False
2636
2637 containsCommas :: Token -> Bool
2638 containsCommas IToparen = True
2639 containsCommas ITobrack = True
2640 -- John doesn't have {} as containing commas, but records contain them,
2641 -- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs
2642 -- (defaultInstallDirs).
2643 containsCommas ITocurly = True
2644 -- GHC Extensions:
2645 containsCommas IToubxparen = True
2646 containsCommas _        = False
2647
2648 topNoLayoutContainsCommas :: [ALRContext] -> Bool
2649 topNoLayoutContainsCommas [] = False
2650 topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
2651 topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
2652
2653 lexToken :: P (RealLocated Token)
2654 lexToken = do
2655   inp@(AI loc1 buf) <- getInput
2656   sc <- getLexState
2657   exts <- getExts
2658   case alexScanUser exts inp sc of
2659     AlexEOF -> do
2660         let span = mkRealSrcSpan loc1 loc1
2661         setLastToken span 0
2662         return (L span ITeof)
2663     AlexError (AI loc2 buf) ->
2664         reportLexError loc1 loc2 buf "lexical error"
2665     AlexSkip inp2 _ -> do
2666         setInput inp2
2667         lexToken
2668     AlexToken inp2@(AI end buf2) _ t -> do
2669         setInput inp2
2670         let span = mkRealSrcSpan loc1 end
2671         let bytes = byteDiff buf buf2
2672         span `seq` setLastToken span bytes
2673         lt <- t span buf bytes
2674         case unLoc lt of
2675           ITlineComment _  -> return lt
2676           ITblockComment _ -> return lt
2677           lt' -> do
2678             setLastTk lt'
2679             return lt
2680
2681 reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
2682 reportLexError loc1 loc2 buf str
2683   | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
2684   | otherwise =
2685   let c = fst (nextChar buf)
2686   in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
2687      then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
2688      else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
2689
2690 lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
2691 lexTokenStream buf loc dflags = unP go initState
2692     where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
2693           initState = mkPState dflags' buf loc
2694           go = do
2695             ltok <- lexer False return
2696             case ltok of
2697               L _ ITeof -> return []
2698               _ -> liftM (ltok:) go
2699
2700 linePrags = Map.singleton "line" (begin line_prag2)
2701
2702 fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),
2703                                  ("options_ghc", lex_string_prag IToptions_prag),
2704                                  ("options_haddock", lex_string_prag ITdocOptions),
2705                                  ("language", token ITlanguage_prag),
2706                                  ("include", lex_string_prag ITinclude_prag)])
2707
2708 ignoredPrags = Map.fromList (map ignored pragmas)
2709                where ignored opt = (opt, nested_comment lexToken)
2710                      impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]
2711                      options_pragmas = map ("options_" ++) impls
2712                      -- CFILES is a hugs-only thing.
2713                      pragmas = options_pragmas ++ ["cfiles", "contract"]
2714
2715 oneWordPrags = Map.fromList([
2716            ("rules", rulePrag),
2717            ("inline", strtoken (\s -> (ITinline_prag s Inline FunLike))),
2718            ("inlinable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))),
2719            ("inlineable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))),
2720                                           -- Spelling variant
2721            ("notinline", strtoken (\s -> (ITinline_prag s NoInline FunLike))),
2722            ("specialize", strtoken (\s -> ITspec_prag s)),
2723            ("source", strtoken (\s -> ITsource_prag s)),
2724            ("warning", strtoken (\s -> ITwarning_prag s)),
2725            ("deprecated", strtoken (\s -> ITdeprecated_prag s)),
2726            ("scc", strtoken (\s -> ITscc_prag s)),
2727            ("generated", strtoken (\s -> ITgenerated_prag s)),
2728            ("core", strtoken (\s -> ITcore_prag s)),
2729            ("unpack", strtoken (\s -> ITunpack_prag s)),
2730            ("nounpack", strtoken (\s -> ITnounpack_prag s)),
2731            ("ann", strtoken (\s -> ITann_prag s)),
2732            ("vectorize", strtoken (\s -> ITvect_prag s)),
2733            ("novectorize", strtoken (\s -> ITnovect_prag s)),
2734            ("minimal", strtoken (\s -> ITminimal_prag s)),
2735            ("overlaps", strtoken (\s -> IToverlaps_prag s)),
2736            ("overlappable", strtoken (\s -> IToverlappable_prag s)),
2737            ("overlapping", strtoken (\s -> IToverlapping_prag s)),
2738            ("incoherent", strtoken (\s -> ITincoherent_prag s)),
2739            ("ctype", strtoken (\s -> ITctype s))])
2740
2741 twoWordPrags = Map.fromList([
2742      ("inline conlike", strtoken (\s -> (ITinline_prag s Inline ConLike))),
2743      ("notinline conlike", strtoken (\s -> (ITinline_prag s NoInline ConLike))),
2744      ("specialize inline", strtoken (\s -> (ITspec_inline_prag s True))),
2745      ("specialize notinline", strtoken (\s -> (ITspec_inline_prag s False))),
2746      ("vectorize scalar", strtoken (\s -> ITvect_scalar_prag s))])
2747
2748 dispatch_pragmas :: Map String Action -> Action
2749 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
2750                                        Just found -> found span buf len
2751                                        Nothing -> lexError "unknown pragma"
2752
2753 known_pragma :: Map String Action -> AlexAccPred ExtsBitmap
2754 known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)
2755  = isKnown && nextCharIsNot curbuf pragmaNameChar
2756     where l = lexemeToString startbuf (byteDiff startbuf curbuf)
2757           isKnown = isJust $ Map.lookup (clean_pragma l) prags
2758           pragmaNameChar c = isAlphaNum c || c == '_'
2759
2760 clean_pragma :: String -> String
2761 clean_pragma prag = canon_ws (map toLower (unprefix prag))
2762                     where unprefix prag' = case stripPrefix "{-#" prag' of
2763                                              Just rest -> rest
2764                                              Nothing -> prag'
2765                           canonical prag' = case prag' of
2766                                               "noinline" -> "notinline"
2767                                               "specialise" -> "specialize"
2768                                               "vectorise" -> "vectorize"
2769                                               "novectorise" -> "novectorize"
2770                                               "constructorlike" -> "conlike"
2771                                               _ -> prag'
2772                           canon_ws s = unwords (map canonical (words s))
2773
2774
2775
2776 {-
2777 %************************************************************************
2778 %*                                                                      *
2779         Helper functions for generating annotations in the parser
2780 %*                                                                      *
2781 %************************************************************************
2782 -}
2783
2784 -- | Encapsulated call to addAnnotation, requiring only the SrcSpan of
2785 --   the AST construct the annotation belongs to; together with the
2786 --   AnnKeywordId, this is is the key of the annotation map
2787 type AddAnn = SrcSpan -> P ()
2788
2789 addAnnotation :: SrcSpan          -- SrcSpan of enclosing AST construct
2790               -> AnnKeywordId     -- The first two parameters are the key
2791               -> SrcSpan          -- The location of the keyword itself
2792               -> P ()
2793 addAnnotation l a v = do
2794   addAnnotationOnly l a v
2795   allocateComments l
2796
2797 addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
2798 addAnnotationOnly l a v = P $ \s -> POk s {
2799   annotations = ((l,a), [v]) : annotations s
2800   } ()
2801
2802 -- |Given a location and a list of AddAnn, apply them all to the location.
2803 addAnnsAt :: SrcSpan -> [AddAnn] -> P ()
2804 addAnnsAt loc anns = mapM_ (\a -> a loc) anns
2805
2806 -- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
2807 -- 'AddAnn' values for the opening and closing bordering on the start
2808 -- and end of the span
2809 mkParensApiAnn :: SrcSpan -> [AddAnn]
2810 mkParensApiAnn (UnhelpfulSpan _)  = []
2811 mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc]
2812   where
2813     mj a l = (\s -> addAnnotation s a l)
2814     f = srcSpanFile ss
2815     sl = srcSpanStartLine ss
2816     sc = srcSpanStartCol ss
2817     el = srcSpanEndLine ss
2818     ec = srcSpanEndCol ss
2819     lo = mkSrcSpan (srcSpanStart s)         (mkSrcLoc f sl (sc+1))
2820     lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s)
2821
2822 -- | Move the annotations and comments belonging to the @old@ span to the @new@
2823 --   one.
2824 moveAnnotations :: SrcSpan -> SrcSpan -> P ()
2825 moveAnnotations old new = P $ \s ->
2826   let
2827     updateAnn ((l,a),v)
2828       | l == old = ((new,a),v)
2829       | otherwise = ((l,a),v)
2830     updateComment (l,c)
2831       | l == old = (new,c)
2832       | otherwise = (l,c)
2833   in
2834     POk s {
2835        annotations = map updateAnn (annotations s)
2836      , annotations_comments = map updateComment (annotations_comments s)
2837      } ()
2838
2839 queueComment :: Located Token -> P()
2840 queueComment c = P $ \s -> POk s {
2841   comment_q = commentToAnnotation c : comment_q s
2842   } ()
2843
2844 -- | Go through the @comment_q@ in @PState@ and remove all comments
2845 -- that belong within the given span
2846 allocateComments :: SrcSpan -> P ()
2847 allocateComments ss = P $ \s ->
2848   let
2849     (before,rest)  = break (\(L l _) -> isSubspanOf l ss) (comment_q s)
2850     (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest
2851     comment_q' = before ++ after
2852     newAnns = if null middle then []
2853                              else [(ss,middle)]
2854   in
2855     POk s {
2856        comment_q = comment_q'
2857      , annotations_comments = newAnns ++ (annotations_comments s)
2858      } ()
2859
2860 commentToAnnotation :: Located Token -> Located AnnotationComment
2861 commentToAnnotation (L l (ITdocCommentNext s))  = L l (AnnDocCommentNext s)
2862 commentToAnnotation (L l (ITdocCommentPrev s))  = L l (AnnDocCommentPrev s)
2863 commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s)
2864 commentToAnnotation (L l (ITdocSection n s))    = L l (AnnDocSection n s)
2865 commentToAnnotation (L l (ITdocOptions s))      = L l (AnnDocOptions s)
2866 commentToAnnotation (L l (ITlineComment s))     = L l (AnnLineComment s)
2867 commentToAnnotation (L l (ITblockComment s))    = L l (AnnBlockComment s)
2868 commentToAnnotation _                           = panic "commentToAnnotation"
2869
2870 -- ---------------------------------------------------------------------
2871
2872 isComment :: Token -> Bool
2873 isComment (ITlineComment     _)   = True
2874 isComment (ITblockComment    _)   = True
2875 isComment _ = False
2876
2877 isDocComment :: Token -> Bool
2878 isDocComment (ITdocCommentNext  _)   = True
2879 isDocComment (ITdocCommentPrev  _)   = True
2880 isDocComment (ITdocCommentNamed _)   = True
2881 isDocComment (ITdocSection      _ _) = True
2882 isDocComment (ITdocOptions      _)   = True
2883 isDocComment _ = False
2884
2885 {- Note [Warnings in code generated by Alex]
2886
2887 We add the following warning suppression flags to all code generated by Alex:
2888
2889 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
2890 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
2891 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
2892 {-# OPTIONS_GHC -fno-warn-tabs #-}
2893 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
2894
2895 Without these flags, current versions of Alex will generate code that is not
2896 warning free. Note that this is the result of Alex' internals, not of the way
2897 we have written our (Lexer).x files.
2898
2899 As always, we need code to be warning free when validating with -Werror.
2900
2901 The list of flags is as short as possible (at the time of writing), to try to
2902 avoid suppressing warnings for bugs in our own code.
2903
2904 TODO. Reevaluate this situation once Alex >3.1.4 is released. Hopefully you
2905 can remove these flags from all (Lexer).x files in the repository, and also
2906 delete this Note. Don't forget to update aclocal.m4, and send a HEADS UP
2907 message to ghc-devs.
2908
2909 The first release of Alex after 3.1.4 will either suppress all warnings itself
2910 [1] (bad), or most warnings will be fixed and only a few select ones will be
2911 suppressed by default [2] (better).
2912
2913 [1] https://github.com/simonmar/alex/commit/1eefcde22ba1bb9b51d523814415714e20f0761e
2914 [2] https://github.com/simonmar/alex/pull/69
2915 -}
2916 }