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