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